diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 9aa016813e..7059dbb7b6 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -14,7 +14,8 @@ module Development.IDE.Plugin.CodeAction , matchRegExMultipleImports ) where -import Bag (isEmptyBag) +import Bag (bagToList, + isEmptyBag) import Control.Applicative ((<|>)) import Control.Arrow (second, (>>>)) @@ -72,7 +73,6 @@ import Outputable (Outputable, showSDocUnsafe) import RdrName (GlobalRdrElt (..), lookupGlobalRdrEnv) -import Safe (atMay) import SrcLoc (realSrcSpanEnd, realSrcSpanStart) import TcRnTypes (ImportAvails (..), @@ -162,6 +162,57 @@ findSigOfDecl pred decls = any (pred . unLoc) idsSig ] +findSigOfDeclRanged :: Range -> [LHsDecl p] -> Maybe (Sig p) +findSigOfDeclRanged range decls = do + dec <- findDeclContainingLoc (_start range) decls + case dec of + L _ (SigD _ sig@TypeSig {}) -> Just sig + L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind + _ -> Nothing + +findSigOfBind :: Range -> HsBind p -> Maybe (Sig p) +findSigOfBind range bind = + case bind of + FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind)) + _ -> Nothing + where + findSigOfLMatch :: [LMatch p (LHsExpr p)] -> Maybe (Sig p) + findSigOfLMatch ls = do + match <- findDeclContainingLoc (_start range) ls + findSigOfGRHSs (m_grhss (unLoc match)) + + findSigOfGRHSs :: GRHSs p (LHsExpr p) -> Maybe (Sig p) + findSigOfGRHSs grhs = do + if _start range `isInsideSrcSpan` (getLoc $ grhssLocalBinds grhs) + then findSigOfBinds range (unLoc (grhssLocalBinds grhs)) -- where clause + else do + grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs) + case unLoc grhs of + GRHS _ _ bd -> findSigOfExpr (unLoc bd) + _ -> Nothing + + findSigOfExpr :: HsExpr p -> Maybe (Sig p) + findSigOfExpr = go + where + go (HsLet _ binds _) = findSigOfBinds range (unLoc binds) + go (HsDo _ _ stmts) = do + stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts) + case stmtlr of + LetStmt _ lhsLocalBindsLR -> findSigOfBinds range $ unLoc lhsLocalBindsLR + _ -> Nothing + go _ = Nothing + +findSigOfBinds :: Range -> HsLocalBinds p -> Maybe (Sig p) +findSigOfBinds range = go + where + go (HsValBinds _ (ValBinds _ binds lsigs)) = + case unLoc <$> findDeclContainingLoc (_start range) lsigs of + Just sig' -> Just sig' + Nothing -> do + lHsBindLR <- findDeclContainingLoc (_start range) (bagToList binds) + findSigOfBind range (unLoc lHsBindLR) + go _ = Nothing + findInstanceHead :: (Outputable (HsType p)) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p) findInstanceHead df instanceHead decls = listToMaybe @@ -173,6 +224,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 @@ -1048,10 +1100,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)] @@ -1090,31 +1138,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 + , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) + <- findSigOfDeclRanged _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 (toRemove df redundantConstraintList) sig + = [(actionTitle redundantConstraintList typeSignatureName, rewrite)] | otherwise = [] where + toRemove df list a = showSDoc df (ppr a) `elem` (T.unpack <$> list) + parseConstraints :: T.Text -> [T.Text] parseConstraints t = t & (T.strip >>> stripConstraintsParens >>> T.splitOn ",") @@ -1134,17 +1177,6 @@ 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 @@ -1152,14 +1184,6 @@ removeRedundantConstraints mContents Diagnostic{..} & 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") <> " `" diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index e5fa05ce8f..2f552e782f 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -11,6 +11,7 @@ module Development.IDE.Plugin.CodeAction.ExactPrint ( -- * Utilities appendConstraint, + removeConstraint, extendImport, hideSymbol, liftParseAST, @@ -119,6 +120,22 @@ fixParens openDP closeDP ctxt@(L _ elems) = do dropHsParTy (L _ (HsParTy _ ty)) = ty dropHsParTy other = other +removeConstraint :: + -- | Predicate: Which context to drop. + (LHsType GhcPs -> Bool) -> + LHsType GhcPs -> + Rewrite +removeConstraint toRemove = go + where + go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite l $ \_ -> do + let ctxt' = L l' $ filter (not . toRemove) ctxt + when ((toRemove <$> headMaybe ctxt) == Just True) $ + setEntryDPT hst_body (DP (0, 0)) + return $ L l $ it{hst_ctxt = 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 :: diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 94529222ed..e1640ae740 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -2685,6 +2685,7 @@ addImplicitParamsConstraintTests = "fCaller :: " <> mkContext contextCaller <> "()", "fCaller = fBase" ] + removeRedundantConstraintsTests :: TestTree removeRedundantConstraintsTests = let header = @@ -2693,6 +2694,13 @@ removeRedundantConstraintsTests = let , "" ] + headerExt :: [T.Text] -> [T.Text] + headerExt exts = + redunt : extTxt ++ ["module Testing where"] + where + redunt = "{-# OPTIONS_GHC -Wredundant-constraints #-}" + extTxt = map (\ext -> "{-# LANGUAGE " <> ext <> " #-}") exts + redundantConstraintsCode :: Maybe T.Text -> T.Text redundantConstraintsCode mConstraint = let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint @@ -2709,11 +2717,73 @@ removeRedundantConstraintsTests = let , "foo x = x == 1" ] - typeSignatureSpaces :: T.Text - typeSignatureSpaces = T.unlines $ header <> - [ "foo :: (Num a, Eq a, Monoid a) => a -> Bool" - , "foo x = x == 1" - ] + typeSignatureSpaces :: Maybe T.Text -> T.Text + typeSignatureSpaces 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" + ] + + redundantConstraintsForall :: Maybe T.Text -> T.Text + redundantConstraintsForall mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ headerExt ["RankNTypes"] <> + [ "foo :: forall a. " <> constraint <> "a -> a" + , "foo = id" + ] + + typeSignatureDo :: Maybe T.Text -> T.Text + typeSignatureDo mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> IO ()" + , "f n = do" + , " let foo :: " <> constraint <> "a -> IO ()" + , " foo _ = return ()" + , " r n" + ] + + typeSignatureNested :: Maybe T.Text -> T.Text + typeSignatureNested mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f = g" + , " where" + , " g :: " <> constraint <> "a -> ()" + , " g _ = ()" + ] + + typeSignatureNested' :: Maybe T.Text -> T.Text + typeSignatureNested' mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f =" + , " let" + , " g :: Int -> ()" + , " g = h" + , " where" + , " h :: " <> constraint <> "a -> ()" + , " h _ = ()" + , " in g" + ] + + typeSignatureNested'' :: Maybe T.Text -> T.Text + typeSignatureNested'' mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f = g" + , " where" + , " g :: Int -> ()" + , " g = " + , " let" + , " h :: " <> constraint <> "a -> ()" + , " h _ = ()" + , " in h" + ] typeSignatureMultipleLines :: T.Text typeSignatureMultipleLines = T.unlines $ header <> @@ -2752,9 +2822,30 @@ removeRedundantConstraintsTests = let "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 + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `g`" + (typeSignatureNested $ Just "Eq a") + (typeSignatureNested Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `h`" + (typeSignatureNested' $ Just "Eq a") + (typeSignatureNested' Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `h`" + (typeSignatureNested'' $ Just "Eq a") + (typeSignatureNested'' Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (redundantConstraintsForall $ Just "Eq a") + (redundantConstraintsForall Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (typeSignatureDo $ Just "Eq a") + (typeSignatureDo Nothing) + , check + "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" + (typeSignatureSpaces $ Just "Monoid a, Show a") + (typeSignatureSpaces Nothing) , checkPeculiarFormatting "should do nothing when constraints contain line feeds" typeSignatureMultipleLines