mirror of
https://github.com/haskell/ghcide.git
synced 2025-01-06 01:44:13 +03:00
Code action to insert new definitions (#309)
* code action to insert new definitions
This commit is contained in:
Pepe Iborra
Moritz Kiefer
parent
1b4cd9d8d7
commit
789f4031e6
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)]
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user