Code action to insert new definitions

src/Development/IDE/Core/Completions.hs

@@ -26,7 +26,6 @@ import Packages
 import DynFlags
 import ConLike
 import DataCon
-import SrcLoc as GHC
 
 import Language.Haskell.LSP.Types
 import Language.Haskell.LSP.Types.Capabilities
@@ -70,12 +69,12 @@ data Context = TypeContext
 -- i.e. where are the value decls and the type decls
 getCContext :: Position -> ParsedModule -> Maybe Context
 getCContext pos pm
-  | Just (L (RealSrcSpan r) modName) <- moduleHeader
-  , pos `isInsideRange` r
+  | Just (L r modName) <- moduleHeader
+  , pos `isInsideSrcSpan` r
   = Just (ModuleContext (moduleNameString modName))
 
-  | Just (L (RealSrcSpan r) _) <- exportList
-  , pos `isInsideRange` r
+  | Just (L r _) <- exportList
+  , pos `isInsideSrcSpan` r
   = Just ExportContext
 
   | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl
@@ -93,54 +92,34 @@ getCContext pos pm
         imports = hsmodImports $ unLoc $ pm_parsed_source pm
 
         go :: LHsDecl GhcPs -> Maybe Context
-        go (L (RealSrcSpan r) SigD {})
-          | pos `isInsideRange` r = Just TypeContext
+        go (L r SigD {})
+          | pos `isInsideSrcSpan` r = Just TypeContext
           | otherwise = Nothing
-        go (L (GHC.RealSrcSpan r) GHC.ValD {})
-          | pos `isInsideRange` r = Just ValueContext
+        go (L r GHC.ValD {})
+          | pos `isInsideSrcSpan` r = Just ValueContext
           | otherwise = Nothing
         go _ = Nothing
 
         goInline :: GHC.LHsType GhcPs -> Maybe Context
-        goInline (GHC.L (GHC.RealSrcSpan r) _)
-          | pos `isInsideRange` r = Just TypeContext
-          | otherwise = Nothing
+        goInline (GHC.L r _)
+          | pos `isInsideSrcSpan` r = Just TypeContext
         goInline _ = Nothing
 
-        p `isInsideRange` r = sp <= p && p <= ep
-          where (sp, ep) = unpackRealSrcSpan r
-
-        -- | Converts from one based tuple
-        toPos :: (Int,Int) -> Position
-        toPos (l,c) = Position (l-1) (c-1)
-
-        unpackRealSrcSpan :: GHC.RealSrcSpan -> (Position, Position)
-        unpackRealSrcSpan rspan =
-          (toPos (l1,c1),toPos (l2,c2))
-          where s  = GHC.realSrcSpanStart rspan
-                l1 = GHC.srcLocLine s
-                c1 = GHC.srcLocCol s
-                e  = GHC.realSrcSpanEnd rspan
-                l2 = GHC.srcLocLine e
-                c2 = GHC.srcLocCol e
-
         importGo :: GHC.LImportDecl GhcPs -> Maybe Context
-        importGo (L (RealSrcSpan r) impDecl)
-          | pos `isInsideRange` r
+        importGo (L r impDecl)
+          | pos `isInsideSrcSpan` r
           = importInline importModuleName (ideclHiding impDecl)
           <|> Just (ImportContext importModuleName)
 
           | otherwise = Nothing
           where importModuleName = moduleNameString $ unLoc $ ideclName impDecl
 
-        importGo _ = Nothing
-
         importInline :: String -> Maybe (Bool,  GHC.Located [LIE GhcPs]) -> Maybe Context
-        importInline modName (Just (True, L (RealSrcSpan r) _))
-          | pos `isInsideRange` r = Just $ ImportHidingContext modName
+        importInline modName (Just (True, L r _))
+          | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName
           | otherwise = Nothing
-        importInline modName (Just (False, L (RealSrcSpan r) _))
-          | pos `isInsideRange` r = Just $ ImportListContext modName
+        importInline modName (Just (False, L r _))
+          | pos `isInsideSrcSpan` r = Just $ ImportListContext modName
           | otherwise = Nothing
         importInline _ _ = Nothing
 
@@ -151,7 +130,7 @@ occNameToComKind ty oc
                      _               -> CiFunction
   | isTcOcc   oc = case ty of
                      Just t
-                       | "Constraint" `T.isSuffixOf` t 
+                       | "Constraint" `T.isSuffixOf` t
                        -> CiClass
                      _ -> CiStruct
   | isDataOcc oc = CiConstructor

src/Development/IDE/GHC/Error.hs

@@ -16,6 +16,7 @@ module Development.IDE.GHC.Error
   , srcSpanToFilename
   , zeroSpan
   , realSpan
+  , isInsideSrcSpan
 
   -- * utilities working with severities
   , toDSeverity
@@ -80,6 +81,10 @@ srcSpanToLocation src =
   -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
   Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)
 
+isInsideSrcSpan :: Position -> SrcSpan -> Bool
+p `isInsideSrcSpan` r = sp <= p && p <= ep
+  where Range sp ep = srcSpanToRange r
+
 -- | Convert a GHC severity to a DAML compiler Severity. Severities below
 -- "Warning" level are dropped (returning Nothing).
 toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity

src/Development/IDE/LSP/CodeAction.hs

@@ -16,10 +16,12 @@ import Control.Monad (join)
 import Development.IDE.GHC.Compat
 import Development.IDE.Core.Rules
 import Development.IDE.Core.RuleTypes
+import Development.IDE.Core.Service
 import Development.IDE.Core.Shake
 import Development.IDE.GHC.Error
 import Development.IDE.LSP.Server
 import Development.IDE.Types.Location
+import Development.IDE.Types.Options
 import qualified Data.HashMap.Strict as Map
 import qualified Data.HashSet as Set
 import qualified Language.Haskell.LSP.Core as LSP
@@ -47,10 +49,12 @@ codeAction lsp state CodeActionParams{_textDocument=TextDocumentIdentifier uri,_
     -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
     contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
     let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
-    parsedModule <- (runAction state . getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri
+    (ideOptions, parsedModule) <- runAction state $
+      (,) <$> getIdeOptions
+          <*> (getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri
     pure $ List
         [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
-        | x <- xs, (title, tedit) <- suggestAction ( join parsedModule ) text x
+        | x <- xs, (title, tedit) <- suggestAction ideOptions ( join parsedModule ) text x
         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
         ]
 
@@ -89,8 +93,8 @@ executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
     | otherwise
     = return (Null, Nothing)
 
-suggestAction  :: Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
-suggestAction parsedModule text diag = concat
+suggestAction  :: IdeOptions -> Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
+suggestAction ideOptions parsedModule text diag = concat
     [ suggestAddExtension diag
     , suggestExtendImport text diag
     , suggestFillHole diag
@@ -100,7 +104,9 @@ suggestAction parsedModule text diag = concat
     , suggestReplaceIdentifier text diag
     , suggestSignature True diag
     ] ++ concat
-    [ suggestRemoveRedundantImport pm text diag | Just pm <- [parsedModule]]
+    [  suggestNewDefinition ideOptions pm text diag
+    ++ suggestRemoveRedundantImport pm text diag
+    | Just pm <- [parsedModule]]
 
 
 suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
@@ -138,6 +144,36 @@ suggestReplaceIdentifier contents Diagnostic{_range=_range@Range{..},..}
         = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
     | otherwise = []
 
+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 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
+    | Range _ lastLineP : _ <-
+      [ srcSpanToRange l
+      | (L l _) <- hsmodDecls
+      , _start `isInsideSrcSpan` l]
+    , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}
+    = [ ("Define " <> sig
+        , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])]
+        )]
+    | otherwise = []
+  where
+    colon = if optNewColonConvention then " : " else " :: "
+    sig = name <> colon <> T.dropWhileEnd isSpace typ
+    ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule
+
+
 suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]
 suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..}
 -- Foo.hs:3:8: error:
@@ -255,8 +291,6 @@ suggestFixConstructorImport _ Diagnostic{_range=_range,..}
 suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
 suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
     | "Top-level binding with no type signature" `T.isInfixOf` _message = let
-      filterNewlines = T.concat  . T.lines
-      unifySpaces    = T.unwords . T.words
       signature      = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
       startOfLine    = Position (_line _start) 0
       beforeLine     = Range startOfLine startOfLine
@@ -265,8 +299,6 @@ suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
       in [(title, [action])]
 suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
     | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let
-      filterNewlines = T.concat  . T.lines
-      unifySpaces    = T.unwords . T.words
       signature      = removeInitialForAll
                      $ T.takeWhile (\x -> x/='*' && x/='•')
                      $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
@@ -403,7 +435,7 @@ addBindingToImportList binding importLine = case T.breakOn "(" importLine of
 
 -- | Returns Just (the submatches) for the first capture, or Nothing.
 matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
-matchRegex message regex = case T.unwords (T.words message) =~~ regex of
+matchRegex message regex = case unifySpaces message =~~ regex of
     Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
     Nothing -> Nothing
 
@@ -418,6 +450,12 @@ setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
     LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
     }
 
+filterNewlines :: T.Text -> T.Text
+filterNewlines = T.concat  . T.lines
+
+unifySpaces :: T.Text -> T.Text
+unifySpaces    = T.unwords . T.words
+
 --------------------------------------------------------------------------------
 
 type PositionIndexedString = [(Position, Char)]

src/Development/IDE/Types/Location.hs

@@ -47,7 +47,7 @@ import Language.Haskell.LSP.Types as LSP (
   , toNormalizedUri
   , fromNormalizedUri
   )
-import GHC
+import SrcLoc as GHC
 import Text.ParserCombinators.ReadP as ReadP
 
 

test/exe/Main.hs

@@ -395,6 +395,7 @@ codeActionTests = testGroup "code actions"
   , importRenameActionTests
   , fillTypedHoleTests
   , addSigActionTests
+  , insertNewDefinitionTests
   ]
 
 codeLensesTests :: TestTree
@@ -412,9 +413,7 @@ renameActionTests = testGroup "rename actions"
             ]
       doc <- openDoc' "Testing.hs" "haskell" content
       _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }]
-          <- getCodeActions doc (Range (Position 2 14) (Position 2 20))
-      liftIO $ "Replace with ‘argName’" @=? actionTitle
+      action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
       executeCodeAction action
       contentAfterAction <- documentContents doc
       let expectedContentAfterAction = T.unlines
@@ -432,9 +431,7 @@ renameActionTests = testGroup "rename actions"
             ]
       doc <- openDoc' "Testing.hs" "haskell" content
       _ <- waitForDiagnostics
-      [CACodeAction action@CodeAction { _title = actionTitle }]
-          <- getCodeActions doc (Range (Position 3 6) (Position 3 16))
-      liftIO $ "Replace with ‘maybeToList’" @=? actionTitle
+      action <- findCodeAction doc (Range (Position 3 6) (Position 3 16))  "Replace with ‘maybeToList’"
       executeCodeAction action
       contentAfterAction <- documentContents doc
       let expectedContentAfterAction = T.unlines
@@ -452,10 +449,9 @@ renameActionTests = testGroup "rename actions"
             ]
       doc <- openDoc' "Testing.hs" "haskell" content
       _ <- waitForDiagnostics
-      actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))
-      let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]
-          expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
-      liftIO $ expectedActionTitles @=? actionTitles
+      _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
+                           ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
+      return()
   , testSession "change infix function" $ do
       let content = T.unlines
             [ "module Testing where"
@@ -809,6 +805,61 @@ extendImportTests = testGroup "extend import actions"
       contentAfterAction <- documentContents docB
       liftIO $ expectedContentB @=? contentAfterAction
 
+insertNewDefinitionTests :: TestTree
+insertNewDefinitionTests = testGroup "insert new definition actions"
+  [ testSession "insert new function definition" $ 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 (txtB ++
+        [ ""
+        , "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')
+  ]
+
 fixConstructorImportTests :: TestTree
 fixConstructorImportTests = testGroup "fix import actions"
   [ testSession "fix constructor import" $ template
@@ -1546,6 +1597,29 @@ openTestDataDoc path = do
   source <- liftIO $ readFileUtf8 $ "test/data" </> path
   openDoc' path "haskell" source
 
+findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
+findCodeActions doc range expectedTitles = do
+  actions <- getCodeActions doc range
+  let matches = sequence
+        [ listToMaybe
+          [ action
+          | CACodeAction action@CodeAction { _title = actionTitle } <- actions
+          , actionTitle == expectedTitle ]
+        | expectedTitle <- expectedTitles]
+  let msg = show
+            [ actionTitle
+            | CACodeAction CodeAction { _title = actionTitle } <- actions
+            ]
+            ++ "is not a superset of "
+            ++ show expectedTitles
+  liftIO $ case matches of
+    Nothing -> assertFailure msg
+    Just _ -> pure ()
+  return (fromJust matches)
+
+findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction
+findCodeAction doc range t = head <$> findCodeActions doc range [t]
+
 unitTests :: TestTree
 unitTests = do
   testGroup "Unit"