Code action: remove redundant constraints for type signature

src/Development/IDE/Plugin/CodeAction.hs

@@ -147,6 +147,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 +587,78 @@ 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
+  = let constraints = findConstraints contents typeSignatureName
+        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 = stripConstraintsParens >>> T.splitOn ", "
+
+      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)
+
+      findConstraints :: T.Text -> T.Text -> T.Text
+      findConstraints contents typeSignatureName = contents
+        & T.splitOn (typeSignatureName <> " ::")
+        & last
+        & T.splitOn "=>"
+        & head
+        & T.strip
+
+      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,55 @@ 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"
+        ]
+
+  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
+
+  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)
+  ]
+
 addSigActionTests :: TestTree
 addSigActionTests = let
   header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"