diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 46307375c4..6ae7047adb 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -63,6 +63,7 @@ import Safe (atMay) import Bag (isEmptyBag) import qualified Data.HashSet as Set import Control.Concurrent.Extra (threadDelay, readVar) +import Development.IDE.GHC.Util (printRdrName) plugin :: Plugin c plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens @@ -178,6 +179,7 @@ suggestExactAction :: suggestExactAction df ps x = concat [ suggestConstraint df (astA ps) x + , suggestImplicitParameter (astA ps) x ] suggestAction @@ -740,7 +742,10 @@ suggestConstraint df parsedModule diag@Diagnostic {..} findMissingConstraint :: T.Text -> Maybe T.Text findMissingConstraint t = let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement - in matchRegexUnifySpaces t regex <&> last + regexImplicitParams = "Could not deduce: (\\?.+) arising from a use of" + match = matchRegexUnifySpaces t regex + matchImplicitParams = matchRegexUnifySpaces t regexImplicitParams + in match <|> matchImplicitParams <&> last -- | Suggests a constraint for an instance declaration for which a constraint is missing. suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] @@ -784,6 +789,19 @@ suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing actionTitle constraint = "Add `" <> constraint <> "` to the context of the instance declaration" +suggestImplicitParameter :: + ParsedSource -> + Diagnostic -> + [(T.Text, Rewrite)] +suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range} + | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising", + Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls, + Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}}) <- findSigOfDecl (== funId) hsmodDecls + = + [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId) + , appendConstraint (T.unpack implicitT) hsib_body)] + | otherwise = [] + findTypeSignatureName :: T.Text -> Maybe T.Text findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 47ef6c2733..c71bef3c3c 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -687,6 +687,7 @@ codeActionTests = testGroup "code actions" , removeRedundantConstraintsTests , addTypeAnnotationsToLiteralsTest , exportUnusedTests + , addImplicitParamsConstraintTests ] codeActionHelperFunctionTests :: TestTree @@ -2050,59 +2051,95 @@ addFunctionConstraintTests = let , " return ()" ] - check :: String -> T.Text -> T.Text -> T.Text -> TestTree - check testName actionTitle originalCode expectedCode = testSession testName $ do - doc <- createDoc "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound)) - chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - in testGroup "add function constraint" - [ check + [ checkCodeAction "no preexisting constraint" "Add `Eq a` to the context of the type signature for `eq`" (missingConstraintSourceCode "") (missingConstraintSourceCode "Eq a => ") - , check + , checkCodeAction "no preexisting constraint, with forall" "Add `Eq a` to the context of the type signature for `eq`" (missingConstraintWithForAllSourceCode "") (missingConstraintWithForAllSourceCode "Eq a => ") - , check + , checkCodeAction "preexisting constraint, no parenthesis" "Add `Eq b` to the context of the type signature for `eq`" (incompleteConstraintSourceCode "Eq a") (incompleteConstraintSourceCode "(Eq a, Eq b)") - , check + , checkCodeAction "preexisting constraints in parenthesis" "Add `Eq c` to the context of the type signature for `eq`" (incompleteConstraintSourceCode2 "(Eq a, Eq b)") (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)") - , check + , checkCodeAction "preexisting constraints with forall" "Add `Eq b` to the context of the type signature for `eq`" (incompleteConstraintWithForAllSourceCode "Eq a") (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)") - , check + , checkCodeAction "preexisting constraint, with extra spaces in context" "Add `Eq b` to the context of the type signature for `eq`" (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a") (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b") - , check + , checkCodeAction "preexisting constraint, with newlines in type signature" "Add `Eq b` to the context of the type signature for `eq`" (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a") (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b") - , check + , checkCodeAction "missing Monad constraint" "Add `Monad m` to the context of the type signature for `f`" (missingMonadConstraint "") (missingMonadConstraint "Monad m => ") ] +checkCodeAction :: String -> T.Text -> T.Text -> T.Text -> TestTree +checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 6 0) (Position 6 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + +addImplicitParamsConstraintTests :: TestTree +addImplicitParamsConstraintTests = + testGroup + "add missing implicit params constraints" + [ testGroup + "introduced" + [ let ex ctxtA = exampleCode "?a" ctxtA "" + in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"), + let ex ctxA = exampleCode "x where x = ?a" ctxA "" + in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()") + ], + testGroup + "inherited" + [ let ex = exampleCode "()" "?a::()" + in checkCodeAction + "with preexisting context" + "Add `?a::()` to the context of the type signature for `fCaller`" + (ex "Eq ()") + (ex "Eq (), ?a::()"), + let ex = exampleCode "()" "?a::()" + in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()") + ] + ] + where + mkContext "" = "" + mkContext contents = "(" <> contents <> ") => " + + exampleCode bodyBase contextBase contextCaller = + T.unlines + [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}", + "module Testing where", + "fBase :: " <> mkContext contextBase <> "()", + "fBase = " <> bodyBase, + "fCaller :: " <> mkContext contextCaller <> "()", + "fCaller = fBase" + ] removeRedundantConstraintsTests :: TestTree removeRedundantConstraintsTests = let header =