mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
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.
This commit is contained in:
parent
6a72d99bfb
commit
4890bafaac
@ -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,
|
||||
|
@ -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])]
|
||||
|
@ -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 #-}"
|
||||
|
Loading…
Reference in New Issue
Block a user