Code action: remove redundant constraints for type signature

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,
@@ -315,6 +316,7 @@ test-suite ghcide-tests
         QuickCheck,
         quickcheck-instances,
         rope-utf16-splay,
+        safe,
         safe-exceptions,
         shake,
         tasty,

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])]

test/exe/Main.hs

@@ -483,6 +483,7 @@ codeActionTests = testGroup "code actions"
   , deleteUnusedDefinitionTests
   , addInstanceConstraintTests
   , addFunctionConstraintTests
+  , removeRedundantConstraintsTests
   , addTypeAnnotationsToLiteralsTest
   ]
 
@@ -1261,7 +1262,7 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t
                , ""
                , "import Debug.Trace"
                , ""
-               , "f a = traceShow \"debug\" a" 
+               , "f a = traceShow \"debug\" a"
                ])
     [ (DsWarning, (6, 6), "Defaulting the following constraint") ]
     "Add type annotation ‘[Char]’ to ‘\"debug\"’"
@@ -1550,6 +1551,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 #-}"