From 4890bafaaccb182b52da18956395b4fd86549366 Mon Sep 17 00:00:00 2001 From: Denis Frezzato Date: Mon, 27 Jul 2020 08:56:54 +0200 Subject: [PATCH] Code action: remove redundant constraints for type signature (#692) * Code action: remove redundant constraints for type signature * Handle peculiar formatting Make the content parsing safe for type signature formatted with an arbitrary and unexpected number of spaces and/or line feeds. --- ghcide.cabal | 2 + src/Development/IDE/Plugin/CodeAction.hs | 81 +++++++++++++++++++++++- test/exe/Main.hs | 76 ++++++++++++++++++++++ 3 files changed, 158 insertions(+), 1 deletion(-) diff --git a/ghcide.cabal b/ghcide.cabal index 272ae41da8..34af880e0a 100644 --- a/ghcide.cabal +++ b/ghcide.cabal @@ -59,6 +59,7 @@ library prettyprinter, regex-tdfa >= 1.3.1.0, rope-utf16-splay, + safe, safe-exceptions, shake >= 0.18.4, sorted-list, @@ -323,6 +324,7 @@ test-suite ghcide-tests QuickCheck, quickcheck-instances, rope-utf16-splay, + safe, safe-exceptions, shake, tasty, diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs index 64a1296080..943e33793c 100644 --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -18,7 +18,7 @@ module Development.IDE.Plugin.CodeAction ) where import Language.Haskell.LSP.Types -import Control.Monad (join) +import Control.Monad (join, guard) import Development.IDE.Plugin import Development.IDE.GHC.Compat import Development.IDE.Core.Rules @@ -57,6 +57,7 @@ import Data.Function import Control.Arrow ((>>>)) import Data.Functor import Control.Applicative ((<|>)) +import Safe (atMay) plugin :: Plugin c plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens @@ -147,6 +148,7 @@ suggestAction dflags packageExports ideOptions parsedModule text diag = concat , suggestReplaceIdentifier text diag , suggestSignature True diag , suggestConstraint text diag + , removeRedundantConstraints text diag , suggestAddTypeAnnotationToSatisfyContraints text diag ] ++ concat [ suggestNewDefinition ideOptions pm text diag @@ -586,6 +588,83 @@ suggestFunctionConstraint contents Diagnostic{..} missingConstraint actionTitle constraint typeSignatureName = "Add `" <> constraint <> "` to the context of the type signature for `" <> typeSignatureName <> "`" +-- | Suggests the removal of a redundant constraint for a type signature. +removeRedundantConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +removeRedundantConstraints mContents Diagnostic{..} +-- • Redundant constraint: Eq a +-- • In the type signature for: +-- foo :: forall a. Eq a => a -> a +-- • Redundant constraints: (Monoid a, Show a) +-- • In the type signature for: +-- foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool + | Just contents <- mContents + -- Account for both "Redundant constraint" and "Redundant constraints". + , True <- "Redundant constraint" `T.isInfixOf` _message + , Just typeSignatureName <- findTypeSignatureName _message + , Just redundantConstraintList <- findRedundantConstraints _message + , Just constraints <- findConstraints contents typeSignatureName + = let constraintList = parseConstraints constraints + newConstraints = buildNewConstraints constraintList redundantConstraintList + typeSignatureLine = findTypeSignatureLine contents typeSignatureName + typeSignatureFirstChar = T.length $ typeSignatureName <> " :: " + startOfConstraint = Position typeSignatureLine typeSignatureFirstChar + endOfConstraint = Position typeSignatureLine $ + typeSignatureFirstChar + T.length (constraints <> " => ") + range = Range startOfConstraint endOfConstraint + in [(actionTitle redundantConstraintList typeSignatureName, [TextEdit range newConstraints])] + | otherwise = [] + where + parseConstraints :: T.Text -> [T.Text] + parseConstraints t = t + & (T.strip >>> stripConstraintsParens >>> T.splitOn ",") + <&> T.strip + + stripConstraintsParens :: T.Text -> T.Text + stripConstraintsParens constraints = + if "(" `T.isPrefixOf` constraints + then constraints & T.drop 1 & T.dropEnd 1 & T.strip + else constraints + + findRedundantConstraints :: T.Text -> Maybe [T.Text] + findRedundantConstraints t = t + & T.lines + & head + & T.strip + & (`matchRegex` "Redundant constraints?: (.+)") + <&> (head >>> parseConstraints) + + -- If the type signature is not formatted as expected (arbitrary number of spaces, + -- line feeds...), just fail. + findConstraints :: T.Text -> T.Text -> Maybe T.Text + findConstraints contents typeSignatureName = do + constraints <- contents + & T.splitOn (typeSignatureName <> " :: ") + & (`atMay` 1) + >>= (T.splitOn " => " >>> (`atMay` 0)) + guard $ not $ "\n" `T.isInfixOf` constraints || T.strip constraints /= constraints + return constraints + + formatConstraints :: [T.Text] -> T.Text + formatConstraints [] = "" + formatConstraints [constraint] = constraint + formatConstraints constraintList = constraintList + & T.intercalate ", " + & \cs -> "(" <> cs <> ")" + + formatConstraintsWithArrow :: [T.Text] -> T.Text + formatConstraintsWithArrow [] = "" + formatConstraintsWithArrow cs = cs & formatConstraints & (<> " => ") + + buildNewConstraints :: [T.Text] -> [T.Text] -> T.Text + buildNewConstraints constraintList redundantConstraintList = + formatConstraintsWithArrow $ constraintList \\ redundantConstraintList + + actionTitle :: [T.Text] -> T.Text -> T.Text + actionTitle constraintList typeSignatureName = + "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `" + <> formatConstraints constraintList + <> "` from the context of the type signature for `" <> typeSignatureName <> "`" + ------------------------------------------------------------------------------------------------- suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])] diff --git a/test/exe/Main.hs b/test/exe/Main.hs index 8c38f35985..171a0bfcb7 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -486,6 +486,7 @@ codeActionTests = testGroup "code actions" , deleteUnusedDefinitionTests , addInstanceConstraintTests , addFunctionConstraintTests + , removeRedundantConstraintsTests , addTypeAnnotationsToLiteralsTest ] @@ -1553,6 +1554,81 @@ addFunctionConstraintTests = let (incompleteConstraintSourceCode2 $ Just "Eq c") ] +removeRedundantConstraintsTests :: TestTree +removeRedundantConstraintsTests = let + header = + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Testing where" + , "" + ] + + redundantConstraintsCode :: Maybe T.Text -> T.Text + redundantConstraintsCode mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> "a -> a" + , "foo = id" + ] + + redundantMixedConstraintsCode :: Maybe T.Text -> T.Text + redundantMixedConstraintsCode mConstraint = + let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> " => a -> Bool" + , "foo x = x == 1" + ] + + typeSignatureSpaces :: T.Text + typeSignatureSpaces = T.unlines $ header <> + [ "foo :: (Num a, Eq a, Monoid a) => a -> Bool" + , "foo x = x == 1" + ] + + typeSignatureMultipleLines :: T.Text + typeSignatureMultipleLines = T.unlines $ header <> + [ "foo :: (Num a, Eq a, Monoid a)" + , "=> a -> Bool" + , "foo x = x == 1" + ] + + check :: T.Text -> T.Text -> T.Text -> TestTree + check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + + checkPeculiarFormatting :: String -> T.Text -> TestTree + checkPeculiarFormatting title code = testSession title $ do + doc <- createDoc "Testing.hs" "haskell" code + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 4 0) (Position 4 maxBound)) + liftIO $ assertBool "Found some actions" (null actionsOrCommands) + + in testGroup "remove redundant function constraints" + [ check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (redundantConstraintsCode $ Just "Eq a") + (redundantConstraintsCode Nothing) + , check + "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`" + (redundantConstraintsCode $ Just "(Eq a, Monoid a)") + (redundantConstraintsCode Nothing) + , check + "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" + (redundantMixedConstraintsCode $ Just "Monoid a, Show a") + (redundantMixedConstraintsCode Nothing) + , checkPeculiarFormatting + "should do nothing when constraints contain an arbitrary number of spaces" + typeSignatureSpaces + , checkPeculiarFormatting + "should do nothing when constraints contain line feeds" + typeSignatureMultipleLines + ] + addSigActionTests :: TestTree addSigActionTests = let header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"