Suggest new definition for named holes

haskell · Jan 9, 2020 · d074a39 · d074a39
1 parent 7715adc
commit d074a39
Show file tree

Hide file tree

Showing 2 changed files with 41 additions and 10 deletions.
diff --git a/src/Development/IDE/LSP/CodeAction.hs b/src/Development/IDE/LSP/CodeAction.hs
@@ -104,7 +104,7 @@ suggestAction ideOptions parsedModule text diag = concat
     , suggestReplaceIdentifier text diag
     , suggestSignature True diag
     ] ++ concat
-    [  suggestNewDefinition ideOptions pm diag
+    [  suggestNewDefinition ideOptions pm text diag
     ++ suggestRemoveRedundantImport pm text diag
     | Just pm <- [parsedModule]]
 
@@ -144,13 +144,18 @@ suggestReplaceIdentifier contents Diagnostic{_range=_range@Range{..},..}
         = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
     | otherwise = []
 
-suggestNewDefinition :: IdeOptions -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestNewDefinition ideOptions parsedModule Diagnostic{_message, _range}
+suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
+suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range}
 --     * Variable not in scope:
 --         suggestAcion :: Maybe T.Text -> Range -> Range
-    | Just [name, typ] <- matchRegex (unifySpaces _message) "Variable not in scope: ([^ ]*) :: ([^*•]*)"
+    | Just [name, typ] <- matchRegex message "Variable not in scope: ([^ ]+) :: ([^*•]+)"
     = newDefinitionAction ideOptions parsedModule _range name typ
+    | Just [name, typ] <- matchRegex message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"
+    , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ
+    = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]
     | otherwise = []
+    where
+      message = unifySpaces _message
 
 newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]
 newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ

diff --git a/test/exe/Main.hs b/test/exe/Main.hs
@@ -809,10 +809,9 @@ insertNewDefinitionTests :: TestTree
 insertNewDefinitionTests = testGroup "insert new definition actions"
   [ testSession "insert new function definition" $ do
       let txtB =
-            ["data Person = Person { age :: Int}"
-            ,"foo True = putStrLn $ head $ showByAge [Person{age = Just 10}]"
+            ["foo True = select [True]"
             , ""
-            ,"foo False = show 0"
+            ,"foo False = False"
             ]
           txtB' =
             [""
@@ -823,13 +822,40 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
       CACodeAction action@CodeAction { _title = actionTitle } : _
                   <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
                      getCodeActions docB (R 1 0 1 50)
-      liftIO $ actionTitle @?= "Define showByAge :: [Person] -> [String]"
+      liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
       executeCodeAction action
       contentAfterAction <- documentContents docB
       liftIO $ contentAfterAction @?= T.unlines (txtB ++
         [ ""
-        , "showByAge :: [Person] -> [String]"
-        , "showByAge = error \"not implemented\""
+        , "select :: [Bool] -> Bool"
+        , "select = error \"not implemented\""
+        ]
+        ++ txtB')
+  , testSession "define a hole" $ do
+      let txtB =
+            ["foo True = _select [True]"
+            , ""
+            ,"foo False = False"
+            ]
+          txtB' =
+            [""
+            ,"someOtherCode = ()"
+            ]
+      docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
+      _ <- waitForDiagnostics
+      CACodeAction action@CodeAction { _title = actionTitle } : _
+                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
+                     getCodeActions docB (R 1 0 1 50)
+      liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
+      executeCodeAction action
+      contentAfterAction <- documentContents docB
+      liftIO $ contentAfterAction @?= T.unlines (
+        ["foo True = select [True]"
+        , ""
+        ,"foo False = False"
+        , ""
+        , "select :: [Bool] -> Bool"
+        , "select = error \"not implemented\""
         ]
         ++ txtB')
   ]