Fix code actions which remove constraints

Author: kderme

ghcide/src/Development/IDE/Plugin/CodeAction.hs

@@ -72,7 +72,6 @@ import           Outputable                                        (Outputable,
                                                                     showSDocUnsafe)
 import           RdrName                                           (GlobalRdrElt (..),
                                                                     lookupGlobalRdrEnv)
-import           Safe                                              (atMay)
 import           SrcLoc                                            (realSrcSpanEnd,
                                                                     realSrcSpanStart)
 import           TcRnTypes                                         (ImportAvails (..),
@@ -162,6 +161,32 @@ findSigOfDecl pred decls =
         any (pred . unLoc) idsSig
     ]
 
+findSigOfDecl' :: Range -> [LHsDecl p] -> Either String (Sig p)
+findSigOfDecl' range decls = do
+  dec <- findDeclContainingLocE (_start range) decls
+  case dec of
+     L _ (SigD _ sig@TypeSig ) -> Right sig
+     L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind
+     _ -> Left "Other"
+
+findSigOfBind :: Range -> HsBind p -> Either String (Sig p)
+findSigOfBind range bind =
+    case bind of
+      FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind))
+      _ -> Left "Other findSigOfBind"
+  where
+    findSigOfLMatch :: [LMatch p (LHsExpr idR)] -> Either String (Sig p)
+    findSigOfLMatch ls = do
+      match <- findDeclContainingLocE (_start range) ls
+      case unLoc (grhssLocalBinds (m_grhss (unLoc match))) of
+        HsValBinds _ (ValBinds _ _ lsigs) ->
+          unLoc <$> findDeclContainingLocE (_start range) lsigs
+        _ -> Left "Other findSigOfLMatch"
+
+findDeclContainingLocE :: Position -> [Located a] -> Either String (Located a)
+findDeclContainingLocE loc ls =
+  maybe (Left "findDeclContainingLoc") Right $ findDeclContainingLoc loc ls
+
 findInstanceHead :: (Outputable (HsType p)) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p)
 findInstanceHead df instanceHead decls =
   listToMaybe
@@ -173,6 +198,7 @@ findInstanceHead df instanceHead decls =
 findDeclContainingLoc :: Position -> [Located a] -> Maybe (Located a)
 findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l)
 
+
 -- Single:
 -- This binding for ‘mod’ shadows the existing binding
 --   imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40
@@ -1020,10 +1046,6 @@ suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _rang
 findTypeSignatureName :: T.Text -> Maybe T.Text
 findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head
 
-findTypeSignatureLine :: T.Text -> T.Text -> Int
-findTypeSignatureLine contents typeSignatureName =
-  T.splitOn (typeSignatureName <> " :: ") contents & head & T.lines & length
-
 -- | Suggests a constraint for a type signature with any number of existing constraints.
 suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]
 
@@ -1062,31 +1084,26 @@ suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing
         <> "` 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{..}
+removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]
+removeRedundantConstraints df (L _ HsModule {hsmodDecls}) 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
+  | "Redundant constraint" `T.isInfixOf` _message
   , Just typeSignatureName <- findTypeSignatureName _message
+  , Right (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}})
+    <- findSigOfDecl' _range hsmodDecls
   , 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)]
+  , rewrite <- removeConstraint (pred df redundantConstraintList) sig
+      = [(actionTitle redundantConstraintList typeSignatureName, rewrite)]
   | otherwise = []
     where
+      pred df list a = showSDoc df (ppr a) `elem` (T.unpack <$> list)
+
       parseConstraints :: T.Text -> [T.Text]
       parseConstraints t = t
         & (T.strip >>> stripConstraintsParens >>> T.splitOn ",")
@@ -1106,32 +1123,13 @@ removeRedundantConstraints mContents Diagnostic{..}
         & (`matchRegexUnifySpaces` "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") <> " `"

ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs

@@ -11,6 +11,7 @@ module Development.IDE.Plugin.CodeAction.ExactPrint (
 
   -- * Utilities
   appendConstraint,
+  removeConstraint,
   extendImport,
   hideSymbol,
   liftParseAST,
@@ -118,6 +119,19 @@ fixParens openDP closeDP ctxt@(L _ elems) = do
   dropHsParTy (L _ (HsParTy _ ty)) = ty
   dropHsParTy other                = other
 
+removeConstraint ::
+  -- | Predicate: Which contect to drop.
+  (LHsType GhcPs -> Bool) ->
+  LHsType GhcPs ->
+  Rewrite
+removeConstraint pred = go
+  where
+    go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite l $ \_ -> do
+      return $ L l $ it{hst_ctxt = L l' $ filter (not . pred) ctxt}
+    go (L _ (HsParTy _ ty)) = go ty
+    go (L _ HsForAllTy{hst_body}) = go hst_body
+    go (L l other) = Rewrite l $ \_ -> return $ L l other
+
 -- | Append a constraint at the end of a type context.
 --   If no context is present, a new one will be created.
 appendConstraint ::