Suggestions for missing implicit parameters

Author: pepeiborra

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
 

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 =