Code action to fill in GHC's suggested type signature for _

Author: hsenag

src/Development/IDE/LSP/CodeAction.hs

@@ -65,6 +65,14 @@ suggestAction contents Diagnostic{_range=_range@Range{..},..}
     | renameSuggestions@(_:_) <- extractRenamableTerms _message
         = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
 
+-- Foo.hs:3:8: error:
+--     * Found type wildcard `_' standing for `p -> p1 -> p'
+
+    | "Found type wildcard" `T.isInfixOf` _message
+    , " standing for " `T.isInfixOf` _message
+    , typeSignature <- extractWildCardTypeSignature _message
+        =  [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]
+
 -- File.hs:22:8: error:
 --     Illegal lambda-case (use -XLambdaCase)
 -- File.hs:22:6: error:
@@ -100,6 +108,14 @@ mkRenameEdit contents range name =
       curr <- textInRange range <$> contents
       pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr
 
+extractWildCardTypeSignature :: T.Text -> T.Text
+extractWildCardTypeSignature =
+  -- inferring when parens are actually needed around the type signature would
+  -- require understanding both the precedence of the context of the _ and of
+  -- the signature itself. Inserting them unconditionally is ugly but safe.
+  ("(" `T.append`) . (`T.append` ")") .
+  T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .
+  snd . T.breakOnEnd "standing for "
 
 extractRenamableTerms :: T.Text -> [T.Text]
 extractRenamableTerms msg

test/exe/Main.hs

@@ -187,6 +187,7 @@ diagnosticTests = testGroup "diagnostics"
 codeActionTests :: TestTree
 codeActionTests = testGroup "code actions"
   [ renameActionTests
+  , typeWildCardActionTests
   ]
 
 renameActionTests :: TestTree
@@ -265,6 +266,76 @@ renameActionTests = testGroup "rename actions"
       liftIO $ expectedContentAfterAction @=? contentAfterAction
   ]
 
+typeWildCardActionTests :: TestTree
+typeWildCardActionTests = testGroup "type wildcard actions"
+  [ testSession "global signature" $ do
+      let content = T.unlines
+            [ "module Testing where"
+            , "func :: _"
+            , "func x = x"
+            ]
+      doc <- openDoc' "Testing.hs" "haskell" content
+      _ <- waitForDiagnostics
+      actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
+      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
+                                   , "Use type signature" `T.isInfixOf` actionTitle
+                           ]
+      executeCodeAction addSignature
+      contentAfterAction <- documentContents doc
+      let expectedContentAfterAction = T.unlines
+            [ "module Testing where"
+            , "func :: (p -> p)"
+            , "func x = x"
+            ]
+      liftIO $ expectedContentAfterAction @=? contentAfterAction
+  , testSession "multi-line message" $ do
+      let content = T.unlines
+            [ "module Testing where"
+            , "func :: _"
+            , "func x y = x + y"
+            ]
+      doc <- openDoc' "Testing.hs" "haskell" content
+      _ <- waitForDiagnostics
+      actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
+      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
+                                    , "Use type signature" `T.isInfixOf` actionTitle
+                              ]
+      executeCodeAction addSignature
+      contentAfterAction <- documentContents doc
+      let expectedContentAfterAction = T.unlines
+            [ "module Testing where"
+            , "func :: (Integer -> Integer -> Integer)"
+            , "func x y = x + y"
+            ]
+      liftIO $ expectedContentAfterAction @=? contentAfterAction
+  , testSession "local signature" $ do
+      let content = T.unlines
+            [ "module Testing where"
+            , "func :: Int -> Int"
+            , "func x ="
+            , "  let y :: _"
+            , "      y = x * 2"
+            , "  in y"
+            ]
+      doc <- openDoc' "Testing.hs" "haskell" content
+      _ <- waitForDiagnostics
+      actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
+      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
+                                    , "Use type signature" `T.isInfixOf` actionTitle
+                              ]
+      executeCodeAction addSignature
+      contentAfterAction <- documentContents doc
+      let expectedContentAfterAction = T.unlines
+            [ "module Testing where"
+            , "func :: Int -> Int"
+            , "func x ="
+            , "  let y :: (Int)"
+            , "      y = x * 2"
+            , "  in y"
+            ]
+      liftIO $ expectedContentAfterAction @=? contentAfterAction
+  ]
+
 ----------------------------------------------------------------------
 -- Utils