mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-02 08:53:07 +03:00
[WIP] Completion support (#227)
* Initial implementation of completion support
* Add fuzzy to set of additional dependencies in 8.8
* Fix test
* Work a bit more on completion
* Attempt at getting completions from last good tckd module
* Revert "Attempt at getting completions from last good tckd module"
This reverts commit 04ca13b9d8.
* "useWithStale" everywhere
* Some suggestions by @cocreature
* Adjust positions in the document
* Start working on tests
* Fix compilation problem
* Fix tests
* Better type tests
This commit is contained in:
Alejandro Serrano
Moritz Kiefer
parent
70cb92cc01
commit
b52ee607f9
@ -39,6 +39,7 @@ library
|
||||
deepseq,
|
||||
directory,
|
||||
extra,
|
||||
fuzzy,
|
||||
filepath,
|
||||
hashable,
|
||||
haskell-lsp-types == 0.19.*,
|
||||
@ -96,6 +97,8 @@ library
|
||||
include-dirs:
|
||||
include
|
||||
exposed-modules:
|
||||
Development.IDE.Core.Completions
|
||||
Development.IDE.Core.CompletionsTypes
|
||||
Development.IDE.Core.FileStore
|
||||
Development.IDE.Core.OfInterest
|
||||
Development.IDE.Core.PositionMapping
|
||||
@ -123,6 +126,7 @@ library
|
||||
Development.IDE.GHC.Warnings
|
||||
Development.IDE.Import.FindImports
|
||||
Development.IDE.LSP.CodeAction
|
||||
Development.IDE.LSP.Completions
|
||||
Development.IDE.LSP.HoverDefinition
|
||||
Development.IDE.LSP.Notifications
|
||||
Development.IDE.Spans.AtPoint
|
||||
@ -180,6 +184,7 @@ test-suite ghcide-tests
|
||||
ghcide:ghcide,
|
||||
ghcide:ghcide-test-preprocessor
|
||||
build-depends:
|
||||
aeson,
|
||||
base,
|
||||
bytestring,
|
||||
containers,
|
||||
|
||||
565
src/Development/IDE/Core/Completions.hs
Normal file
565
src/Development/IDE/Core/Completions.hs
Normal file
@ -0,0 +1,565 @@
|
||||
-- Mostly taken from "haskell-ide-engine"
|
||||
module Development.IDE.Core.Completions (
|
||||
CachedCompletions
|
||||
, cacheDataProducer
|
||||
, WithSnippets(..)
|
||||
,getCompletions
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
import Data.Char (isSpace)
|
||||
import Data.Generics
|
||||
import Data.List as List hiding (stripPrefix)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import qualified Data.Text as T
|
||||
import qualified Text.Fuzzy as Fuzzy
|
||||
|
||||
import GHC
|
||||
import Module
|
||||
import HscTypes
|
||||
import Name
|
||||
import RdrName
|
||||
import TcRnTypes
|
||||
import Type
|
||||
import Var
|
||||
import Packages
|
||||
import DynFlags
|
||||
import ConLike
|
||||
import DataCon
|
||||
import SrcLoc as GHC
|
||||
|
||||
import Language.Haskell.LSP.Types
|
||||
import Language.Haskell.LSP.Types.Capabilities
|
||||
import qualified Language.Haskell.LSP.VFS as VFS
|
||||
import Development.IDE.Core.CompletionsTypes
|
||||
import Development.IDE.Spans.Documentation
|
||||
|
||||
-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
|
||||
|
||||
data NameDetails
|
||||
= NameDetails Module OccName
|
||||
deriving (Eq)
|
||||
|
||||
nsJSON :: NameSpace -> Value
|
||||
nsJSON ns
|
||||
| isVarNameSpace ns = String "v"
|
||||
| isDataConNameSpace ns = String "c"
|
||||
| isTcClsNameSpace ns = String "t"
|
||||
| isTvNameSpace ns = String "z"
|
||||
| otherwise = error "namespace not recognized"
|
||||
|
||||
parseNs :: Value -> Parser NameSpace
|
||||
parseNs (String "v") = pure Name.varName
|
||||
parseNs (String "c") = pure dataName
|
||||
parseNs (String "t") = pure tcClsName
|
||||
parseNs (String "z") = pure tvName
|
||||
parseNs _ = mempty
|
||||
|
||||
instance FromJSON NameDetails where
|
||||
parseJSON v@(Array _)
|
||||
= do
|
||||
[modname,modid,namesp,occname] <- parseJSON v
|
||||
mn <- parseJSON modname
|
||||
mid <- parseJSON modid
|
||||
ns <- parseNs namesp
|
||||
occn <- parseJSON occname
|
||||
pure $ NameDetails (mkModule (stringToUnitId mid) (mkModuleName mn)) (mkOccName ns occn)
|
||||
parseJSON _ = mempty
|
||||
instance ToJSON NameDetails where
|
||||
toJSON (NameDetails mdl occ) = toJSON [toJSON mname,toJSON mid,nsJSON ns,toJSON occs]
|
||||
where
|
||||
mname = moduleNameString $ moduleName mdl
|
||||
mid = unitIdString $ moduleUnitId mdl
|
||||
ns = occNameSpace occ
|
||||
occs = occNameString occ
|
||||
|
||||
safeTyThingId :: TyThing -> Maybe Id
|
||||
safeTyThingId (AnId i) = Just i
|
||||
safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc
|
||||
safeTyThingId _ = Nothing
|
||||
|
||||
-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
|
||||
|
||||
-- | A context of a declaration in the program
|
||||
-- e.g. is the declaration a type declaration or a value declaration
|
||||
-- Used for determining which code completions to show
|
||||
-- TODO: expand this with more contexts like classes or instances for
|
||||
-- smarter code completion
|
||||
data Context = TypeContext
|
||||
| ValueContext
|
||||
| ModuleContext String -- ^ module context with module name
|
||||
| ImportContext String -- ^ import context with module name
|
||||
| ImportListContext String -- ^ import list context with module name
|
||||
| ImportHidingContext String -- ^ import hiding context with module name
|
||||
| ExportContext -- ^ List of exported identifiers from the current module
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | Generates a map of where the context is a type and where the context is a value
|
||||
-- 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 (ModuleContext (moduleNameString modName))
|
||||
|
||||
| Just (L (RealSrcSpan r) _) <- exportList
|
||||
, pos `isInsideRange` r
|
||||
= Just ExportContext
|
||||
|
||||
| Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl
|
||||
= Just ctx
|
||||
|
||||
| Just ctx <- something (Nothing `mkQ` importGo) imports
|
||||
= Just ctx
|
||||
|
||||
| otherwise
|
||||
= Nothing
|
||||
|
||||
where decl = hsmodDecls $ unLoc $ pm_parsed_source pm
|
||||
moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm
|
||||
exportList = hsmodExports $ unLoc $ pm_parsed_source pm
|
||||
imports = hsmodImports $ unLoc $ pm_parsed_source pm
|
||||
|
||||
go :: LHsDecl GhcPs -> Maybe Context
|
||||
go (L (RealSrcSpan r) SigD {})
|
||||
| pos `isInsideRange` r = Just TypeContext
|
||||
| otherwise = Nothing
|
||||
go (L (GHC.RealSrcSpan r) GHC.ValD {})
|
||||
| pos `isInsideRange` 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 _ = 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
|
||||
= 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
|
||||
| otherwise = Nothing
|
||||
importInline modName (Just (False, L (RealSrcSpan r) _))
|
||||
| pos `isInsideRange` r = Just $ ImportListContext modName
|
||||
| otherwise = Nothing
|
||||
importInline _ _ = Nothing
|
||||
|
||||
type CompItemResolveData
|
||||
= Maybe NameDetails
|
||||
|
||||
occNameToComKind :: OccName -> CompletionItemKind
|
||||
occNameToComKind oc
|
||||
| isVarOcc oc = CiFunction
|
||||
| isTcOcc oc = CiClass
|
||||
| isDataOcc oc = CiConstructor
|
||||
| otherwise = CiVariable
|
||||
|
||||
mkCompl :: CompItem -> CompletionItem
|
||||
mkCompl CI{origName,importedFrom,thingType,label,isInfix,docs} =
|
||||
CompletionItem label kind (Just $ maybe "" (<>"\n") typeText <> importedFrom)
|
||||
(Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs)
|
||||
Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
|
||||
Nothing Nothing Nothing Nothing resolveData
|
||||
where kind = Just $ occNameToComKind $ occName origName
|
||||
resolveData = Just (toJSON nameDets)
|
||||
insertText = case isInfix of
|
||||
Nothing -> case getArgText <$> thingType of
|
||||
Nothing -> label
|
||||
Just argText -> label <> " " <> argText
|
||||
Just LeftSide -> label <> "`"
|
||||
|
||||
Just Surrounded -> label
|
||||
typeText
|
||||
| Just t <- thingType = Just . stripForall $ T.pack (showGhc t)
|
||||
| otherwise = Nothing
|
||||
nameDets =
|
||||
case (thingType, nameModule_maybe origName) of
|
||||
(Just _,_) -> Nothing
|
||||
(Nothing, Nothing) -> Nothing
|
||||
(Nothing, Just mdl) -> Just (NameDetails mdl (nameOccName origName))
|
||||
|
||||
stripForall :: T.Text -> T.Text
|
||||
stripForall t
|
||||
| T.isPrefixOf "forall" t =
|
||||
-- We drop 2 to remove the '.' and the space after it
|
||||
T.drop 2 (T.dropWhile (/= '.') t)
|
||||
| otherwise = t
|
||||
|
||||
getArgText :: Type -> T.Text
|
||||
getArgText typ = argText
|
||||
where
|
||||
argTypes = getArgs typ
|
||||
argText :: T.Text
|
||||
argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes
|
||||
snippet :: Int -> Type -> T.Text
|
||||
snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"
|
||||
getArgs :: Type -> [Type]
|
||||
getArgs t
|
||||
| isPredTy t = []
|
||||
| isDictTy t = []
|
||||
| isForAllTy t = getArgs $ snd (splitForAllTys t)
|
||||
| isFunTy t =
|
||||
let (args, ret) = splitFunTys t
|
||||
in if isForAllTy ret
|
||||
then getArgs ret
|
||||
else Prelude.filter (not . isDictTy) args
|
||||
| isPiTy t = getArgs $ snd (splitPiTys t)
|
||||
| isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)
|
||||
| otherwise = []
|
||||
|
||||
mkModCompl :: T.Text -> CompletionItem
|
||||
mkModCompl label =
|
||||
CompletionItem label (Just CiModule) Nothing
|
||||
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
Nothing Nothing Nothing Nothing (Just $ toJSON resolveData)
|
||||
where resolveData :: CompItemResolveData
|
||||
resolveData = Nothing
|
||||
|
||||
mkImportCompl :: T.Text -> T.Text -> CompletionItem
|
||||
mkImportCompl enteredQual label =
|
||||
CompletionItem m (Just CiModule) (Just label)
|
||||
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
Nothing Nothing Nothing Nothing Nothing
|
||||
where
|
||||
m = fromMaybe "" (T.stripPrefix enteredQual label)
|
||||
|
||||
mkExtCompl :: T.Text -> CompletionItem
|
||||
mkExtCompl label =
|
||||
CompletionItem label (Just CiKeyword) Nothing
|
||||
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
mkPragmaCompl :: T.Text -> T.Text -> CompletionItem
|
||||
mkPragmaCompl label insertText =
|
||||
CompletionItem label (Just CiKeyword) Nothing
|
||||
Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
|
||||
Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
cacheDataProducer :: DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions
|
||||
cacheDataProducer dflags tm tcs = do
|
||||
let parsedMod = tm_parsed_module tm
|
||||
curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod
|
||||
Just (_,limports,_,_) = tm_renamed_source tm
|
||||
|
||||
iDeclToModName :: ImportDecl name -> ModuleName
|
||||
iDeclToModName = unLoc . ideclName
|
||||
|
||||
showModName :: ModuleName -> T.Text
|
||||
showModName = T.pack . moduleNameString
|
||||
|
||||
asNamespace :: ImportDecl name -> ModuleName
|
||||
asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp)
|
||||
-- Full canonical names of imported modules
|
||||
importDeclerations = map unLoc limports
|
||||
|
||||
-- The list of all importable Modules from all packages
|
||||
moduleNames = map showModName (listVisibleModuleNames dflags)
|
||||
|
||||
-- The given namespaces for the imported modules (ie. full name, or alias if used)
|
||||
allModNamesAsNS = map (showModName . asNamespace) importDeclerations
|
||||
|
||||
typeEnv = tcg_type_env $ fst $ tm_internals_ tm
|
||||
rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm
|
||||
rdrElts = globalRdrEnvElts rdrEnv
|
||||
|
||||
getCompls :: [GlobalRdrElt] -> ([CompItem],QualCompls)
|
||||
getCompls = foldMap getComplsForOne
|
||||
|
||||
getComplsForOne :: GlobalRdrElt -> ([CompItem],QualCompls)
|
||||
getComplsForOne (GRE n _ True _) =
|
||||
case lookupTypeEnv typeEnv n of
|
||||
Just tt -> case safeTyThingId tt of
|
||||
Just var -> ([varToCompl var],mempty)
|
||||
Nothing -> ([toCompItem curMod n],mempty)
|
||||
Nothing -> ([toCompItem curMod n],mempty)
|
||||
getComplsForOne (GRE n _ False prov) =
|
||||
flip foldMap (map is_decl prov) $ \spec ->
|
||||
let unqual
|
||||
| is_qual spec = []
|
||||
| otherwise = compItem
|
||||
qual
|
||||
| is_qual spec = Map.singleton asMod compItem
|
||||
| otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]
|
||||
compItem = [toCompItem (is_mod spec) n]
|
||||
asMod = showModName (is_as spec)
|
||||
origMod = showModName (is_mod spec)
|
||||
in (unqual,QualCompls qual)
|
||||
|
||||
varToCompl :: Var -> CompItem
|
||||
varToCompl var = CI name (showModName curMod) typ label Nothing docs
|
||||
where
|
||||
typ = Just $ varType var
|
||||
name = Var.varName var
|
||||
label = T.pack $ showGhc name
|
||||
docs = getDocumentation tcs name
|
||||
|
||||
toCompItem :: ModuleName -> Name -> CompItem
|
||||
toCompItem mn n =
|
||||
CI n (showModName mn) Nothing (T.pack $ showGhc n) Nothing (getDocumentation tcs n)
|
||||
|
||||
(unquals,quals) = getCompls rdrElts
|
||||
|
||||
return $ CC
|
||||
{ allModNamesAsNS = allModNamesAsNS
|
||||
, unqualCompls = unquals
|
||||
, qualCompls = quals
|
||||
, importableModules = moduleNames
|
||||
}
|
||||
|
||||
newtype WithSnippets = WithSnippets Bool
|
||||
|
||||
toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem
|
||||
toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
|
||||
| with && supported = x
|
||||
| otherwise = x { _insertTextFormat = Just PlainText
|
||||
, _insertText = Nothing
|
||||
}
|
||||
where supported = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
|
||||
|
||||
-- | Returns the cached completions for the given module and position.
|
||||
getCompletions :: CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
|
||||
getCompletions CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }
|
||||
tm prefixInfo caps withSnippets = do
|
||||
let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo
|
||||
enteredQual = if T.null prefixModule then "" else prefixModule <> "."
|
||||
fullPrefix = enteredQual <> prefixText
|
||||
|
||||
-- default to value context if no explicit context
|
||||
context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)
|
||||
|
||||
{- correct the position by moving 'foo :: Int -> String -> '
|
||||
^
|
||||
to 'foo :: Int -> String -> '
|
||||
^
|
||||
-}
|
||||
pos =
|
||||
let Position l c = VFS.cursorPos prefixInfo
|
||||
typeStuff = [isSpace, (`elem` (">-." :: String))]
|
||||
stripTypeStuff = T.dropWhileEnd (\x -> any (\f -> f x) typeStuff)
|
||||
-- if oldPos points to
|
||||
-- foo -> bar -> baz
|
||||
-- ^
|
||||
-- Then only take the line up to there, discard '-> bar -> baz'
|
||||
partialLine = T.take c fullLine
|
||||
-- drop characters used when writing incomplete type sigs
|
||||
-- like '-> '
|
||||
d = T.length fullLine - T.length (stripTypeStuff partialLine)
|
||||
in Position l (c - d)
|
||||
|
||||
filtModNameCompls =
|
||||
map mkModCompl
|
||||
$ mapMaybe (T.stripPrefix enteredQual)
|
||||
$ Fuzzy.simpleFilter fullPrefix allModNamesAsNS
|
||||
|
||||
filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False
|
||||
where
|
||||
isTypeCompl = isTcOcc . occName . origName
|
||||
-- completions specific to the current context
|
||||
ctxCompls' = case context of
|
||||
TypeContext -> filter isTypeCompl compls
|
||||
ValueContext -> filter (not . isTypeCompl) compls
|
||||
_ -> filter (not . isTypeCompl) compls
|
||||
-- Add whether the text to insert has backticks
|
||||
ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
|
||||
|
||||
infixCompls :: Maybe Backtick
|
||||
infixCompls = isUsedAsInfix fullLine prefixModule prefixText (VFS.cursorPos prefixInfo)
|
||||
|
||||
compls = if T.null prefixModule
|
||||
then unqualCompls
|
||||
else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls
|
||||
|
||||
filtListWith f list =
|
||||
[ f label
|
||||
| label <- Fuzzy.simpleFilter fullPrefix list
|
||||
, enteredQual `T.isPrefixOf` label
|
||||
]
|
||||
|
||||
filtListWithSnippet f list suffix =
|
||||
[ toggleSnippets caps withSnippets (f label (snippet <> suffix))
|
||||
| (snippet, label) <- list
|
||||
, Fuzzy.test fullPrefix label
|
||||
]
|
||||
|
||||
filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
|
||||
filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas
|
||||
filtOptsCompls = filtListWith mkExtCompl
|
||||
|
||||
stripLeading :: Char -> String -> String
|
||||
stripLeading _ [] = []
|
||||
stripLeading c (s:ss)
|
||||
| s == c = ss
|
||||
| otherwise = s:ss
|
||||
|
||||
result
|
||||
| "import " `T.isPrefixOf` fullLine
|
||||
= filtImportCompls
|
||||
| "{-# language" `T.isPrefixOf` T.toLower fullLine
|
||||
= filtOptsCompls languagesAndExts
|
||||
| "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine
|
||||
= filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)
|
||||
| "{-# " `T.isPrefixOf` fullLine
|
||||
= filtPragmaCompls (pragmaSuffix fullLine)
|
||||
| otherwise
|
||||
= filtModNameCompls ++ map (toggleSnippets caps withSnippets
|
||||
. mkCompl . stripAutoGenerated) filtCompls
|
||||
|
||||
return result
|
||||
|
||||
-- The supported languages and extensions
|
||||
languagesAndExts :: [T.Text]
|
||||
languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- helper functions for pragmas
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
validPragmas :: [(T.Text, T.Text)]
|
||||
validPragmas =
|
||||
[ ("LANGUAGE ${1:extension}" , "LANGUAGE")
|
||||
, ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC")
|
||||
, ("INLINE ${1:function}" , "INLINE")
|
||||
, ("NOINLINE ${1:function}" , "NOINLINE")
|
||||
, ("INLINABLE ${1:function}" , "INLINABLE")
|
||||
, ("WARNING ${1:message}" , "WARNING")
|
||||
, ("DEPRECATED ${1:message}" , "DEPRECATED")
|
||||
, ("ANN ${1:annotation}" , "ANN")
|
||||
, ("RULES" , "RULES")
|
||||
, ("SPECIALIZE ${1:function}" , "SPECIALIZE")
|
||||
, ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE")
|
||||
]
|
||||
|
||||
pragmaSuffix :: T.Text -> T.Text
|
||||
pragmaSuffix fullLine
|
||||
| "}" `T.isSuffixOf` fullLine = mempty
|
||||
| otherwise = " #-}"
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- helper functions for infix backticks
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
hasTrailingBacktick :: T.Text -> Position -> Bool
|
||||
hasTrailingBacktick line Position { _character }
|
||||
| T.length line > _character = (line `T.index` _character) == '`'
|
||||
| otherwise = False
|
||||
|
||||
isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick
|
||||
isUsedAsInfix line prefixMod prefixText pos
|
||||
| hasClosingBacktick && hasOpeningBacktick = Just Surrounded
|
||||
| hasOpeningBacktick = Just LeftSide
|
||||
| otherwise = Nothing
|
||||
where
|
||||
hasOpeningBacktick = openingBacktick line prefixMod prefixText pos
|
||||
hasClosingBacktick = hasTrailingBacktick line pos
|
||||
|
||||
openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool
|
||||
openingBacktick line prefixModule prefixText Position { _character }
|
||||
| backtickIndex < 0 = False
|
||||
| otherwise = (line `T.index` backtickIndex) == '`'
|
||||
where
|
||||
backtickIndex :: Int
|
||||
backtickIndex =
|
||||
let
|
||||
prefixLength = T.length prefixText
|
||||
moduleLength = if prefixModule == ""
|
||||
then 0
|
||||
else T.length prefixModule + 1 {- Because of "." -}
|
||||
in
|
||||
-- Points to the first letter of either the module or prefix text
|
||||
_character - (prefixLength + moduleLength) - 1
|
||||
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
-- | Under certain circumstance GHC generates some extra stuff that we
|
||||
-- don't want in the autocompleted symbols
|
||||
stripAutoGenerated :: CompItem -> CompItem
|
||||
stripAutoGenerated ci =
|
||||
ci {label = stripPrefix (label ci)}
|
||||
{- When e.g. DuplicateRecordFields is enabled, compiler generates
|
||||
names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors
|
||||
https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
|
||||
-}
|
||||
|
||||
-- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.
|
||||
|
||||
stripPrefix :: T.Text -> T.Text
|
||||
stripPrefix name = T.takeWhile (/=':') $ go prefixes
|
||||
where
|
||||
go [] = name
|
||||
go (p:ps)
|
||||
| T.isPrefixOf p name = T.drop (T.length p) name
|
||||
| otherwise = go ps
|
||||
|
||||
-- | Prefixes that can occur in a GHC OccName
|
||||
prefixes :: [T.Text]
|
||||
prefixes =
|
||||
[
|
||||
-- long ones
|
||||
"$con2tag_"
|
||||
, "$tag2con_"
|
||||
, "$maxtag_"
|
||||
|
||||
-- four chars
|
||||
, "$sel:"
|
||||
, "$tc'"
|
||||
|
||||
-- three chars
|
||||
, "$dm"
|
||||
, "$co"
|
||||
, "$tc"
|
||||
, "$cp"
|
||||
, "$fx"
|
||||
|
||||
-- two chars
|
||||
, "$W"
|
||||
, "$w"
|
||||
, "$m"
|
||||
, "$b"
|
||||
, "$c"
|
||||
, "$d"
|
||||
, "$i"
|
||||
, "$s"
|
||||
, "$f"
|
||||
, "$r"
|
||||
, "C:"
|
||||
, "N:"
|
||||
, "D:"
|
||||
, "$p"
|
||||
, "$L"
|
||||
, "$f"
|
||||
, "$t"
|
||||
, "$c"
|
||||
, "$m"
|
||||
]
|
||||
62
src/Development/IDE/Core/CompletionsTypes.hs
Normal file
62
src/Development/IDE/Core/CompletionsTypes.hs
Normal file
@ -0,0 +1,62 @@
|
||||
module Development.IDE.Core.CompletionsTypes (
|
||||
module Development.IDE.Core.CompletionsTypes
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
|
||||
import GHC
|
||||
import Outputable
|
||||
import DynFlags
|
||||
|
||||
-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs
|
||||
|
||||
showGhc :: Outputable a => a -> String
|
||||
showGhc = showPpr unsafeGlobalDynFlags
|
||||
|
||||
data Backtick = Surrounded | LeftSide deriving Show
|
||||
data CompItem = CI
|
||||
{ origName :: Name -- ^ Original name, such as Maybe, //, or find.
|
||||
, importedFrom :: T.Text -- ^ From where this item is imported from.
|
||||
, thingType :: Maybe Type -- ^ Available type information.
|
||||
, label :: T.Text -- ^ Label to display to the user.
|
||||
, isInfix :: Maybe Backtick -- ^ Did the completion happen
|
||||
-- in the context of an infix notation.
|
||||
, docs :: [T.Text] -- ^ Available documentation.
|
||||
}
|
||||
instance Show CompItem where
|
||||
show CI { .. } = "CompItem { origName = \"" ++ showGhc origName ++ "\""
|
||||
++ ", importedFrom = " ++ show importedFrom
|
||||
++ ", thingType = " ++ show (fmap showGhc thingType)
|
||||
++ ", label = " ++ show label
|
||||
++ ", isInfix = " ++ show isInfix
|
||||
++ ", docs = " ++ show docs
|
||||
++ " } "
|
||||
instance Eq CompItem where
|
||||
ci1 == ci2 = origName ci1 == origName ci2
|
||||
instance Ord CompItem where
|
||||
compare ci1 ci2 = origName ci1 `compare` origName ci2
|
||||
|
||||
-- Associates a module's qualifier with its members
|
||||
newtype QualCompls
|
||||
= QualCompls { getQualCompls :: Map.Map T.Text [CompItem] }
|
||||
deriving Show
|
||||
instance Semigroup QualCompls where
|
||||
(QualCompls a) <> (QualCompls b) = QualCompls $ Map.unionWith (++) a b
|
||||
instance Monoid QualCompls where
|
||||
mempty = QualCompls Map.empty
|
||||
mappend = (Prelude.<>)
|
||||
|
||||
-- | End result of the completions
|
||||
data CachedCompletions = CC
|
||||
{ allModNamesAsNS :: [T.Text] -- ^ All module names in scope.
|
||||
-- Prelude is a single module
|
||||
, unqualCompls :: [CompItem] -- ^ All Possible completion items
|
||||
, qualCompls :: QualCompls -- ^ Completion items associated to
|
||||
-- to a specific module name.
|
||||
, importableModules :: [T.Text] -- ^ All modules that may be imported.
|
||||
} deriving Show
|
||||
|
||||
instance NFData CachedCompletions where
|
||||
rnf = rwhnf
|
||||
@ -27,6 +27,7 @@ import Module (InstalledUnitId)
|
||||
import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
|
||||
import Development.IDE.GHC.Compat
|
||||
|
||||
import Development.IDE.Core.CompletionsTypes
|
||||
import Development.IDE.Spans.Type
|
||||
|
||||
|
||||
@ -85,6 +86,9 @@ type instance RuleResult ReportImportCycles = ()
|
||||
-- | Read the given HIE file.
|
||||
type instance RuleResult GetHieFile = HieFile
|
||||
|
||||
-- | Produce completions info for a file
|
||||
type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult)
|
||||
|
||||
|
||||
data GetParsedModule = GetParsedModule
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
@ -153,3 +157,9 @@ data GetHieFile = GetHieFile FilePath
|
||||
instance Hashable GetHieFile
|
||||
instance NFData GetHieFile
|
||||
instance Binary GetHieFile
|
||||
|
||||
data ProduceCompletions = ProduceCompletions
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable ProduceCompletions
|
||||
instance NFData ProduceCompletions
|
||||
instance Binary ProduceCompletions
|
||||
@ -32,6 +32,7 @@ import Control.Monad
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Development.IDE.Core.Compile
|
||||
import Development.IDE.Core.Completions
|
||||
import Development.IDE.Types.Options
|
||||
import Development.IDE.Spans.Calculate
|
||||
import Development.IDE.Import.DependencyInformation
|
||||
@ -304,6 +305,19 @@ generateCoreRule :: Rules ()
|
||||
generateCoreRule =
|
||||
define $ \GenerateCore -> generateCore
|
||||
|
||||
produceCompletions :: Rules ()
|
||||
produceCompletions =
|
||||
define $ \ProduceCompletions file -> do
|
||||
deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
|
||||
tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
|
||||
tm <- fmap fst <$> useWithStale TypeCheck file
|
||||
dflags <- fmap (hsc_dflags . hscEnv . fst) <$> useWithStale GhcSession file
|
||||
case (tm, dflags) of
|
||||
(Just tm', Just dflags') -> do
|
||||
cdata <- liftIO $ cacheDataProducer dflags' (tmrModule tm') (map tmrModule tms)
|
||||
return ([], Just (cdata, tm'))
|
||||
_ -> return ([], Nothing)
|
||||
|
||||
generateByteCodeRule :: Rules ()
|
||||
generateByteCodeRule =
|
||||
define $ \GenerateByteCode file -> do
|
||||
@ -361,6 +375,7 @@ mainRule = do
|
||||
generateByteCodeRule
|
||||
loadGhcSession
|
||||
getHieFileRule
|
||||
produceCompletions
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
|
||||
46
src/Development/IDE/LSP/Completions.hs
Normal file
46
src/Development/IDE/LSP/Completions.hs
Normal file
@ -0,0 +1,46 @@
|
||||
module Development.IDE.LSP.Completions (
|
||||
setHandlersCompletion
|
||||
) where
|
||||
|
||||
import Language.Haskell.LSP.Messages
|
||||
import Language.Haskell.LSP.Types
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import qualified Language.Haskell.LSP.VFS as VFS
|
||||
import Language.Haskell.LSP.Types.Capabilities
|
||||
|
||||
import Development.IDE.Core.Service
|
||||
import Development.IDE.Core.Completions
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Core.PositionMapping
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.Core.Shake
|
||||
import Development.IDE.LSP.Server
|
||||
|
||||
-- | Generate code actions.
|
||||
getCompletionsLSP
|
||||
:: LSP.LspFuncs ()
|
||||
-> IdeState
|
||||
-> CompletionParams
|
||||
-> IO CompletionResponseResult
|
||||
getCompletionsLSP lsp ide CompletionParams{_textDocument=TextDocumentIdentifier uri,_position=position} = do
|
||||
contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
|
||||
case (contents, uriToFilePath' uri) of
|
||||
(Just cnts, Just path) -> do
|
||||
let npath = toNormalizedFilePath path
|
||||
compls <- runAction ide (useWithStale ProduceCompletions npath)
|
||||
case compls of
|
||||
Just ((cci', tm'), mapping) -> do
|
||||
let position' = fromCurrentPosition mapping position
|
||||
pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
|
||||
case pfix of
|
||||
Just pfix' -> do
|
||||
let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
|
||||
Completions . List <$> getCompletions cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)
|
||||
_ -> return (Completions $ List [])
|
||||
_ -> return (Completions $ List [])
|
||||
_ -> return (Completions $ List [])
|
||||
|
||||
setHandlersCompletion :: PartialHandlers
|
||||
setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
|
||||
LSP.completionHandler = withResponse RspCompletion getCompletionsLSP
|
||||
}
|
||||
@ -30,6 +30,7 @@ import Control.Monad.Extra
|
||||
|
||||
import Development.IDE.LSP.HoverDefinition
|
||||
import Development.IDE.LSP.CodeAction
|
||||
import Development.IDE.LSP.Completions
|
||||
import Development.IDE.LSP.Notifications
|
||||
import Development.IDE.Core.Service
|
||||
import Development.IDE.Types.Logger
|
||||
@ -97,6 +98,7 @@ runLanguageServer options userHandlers getIdeState = do
|
||||
setHandlersIgnore <> -- least important
|
||||
setHandlersDefinition <> setHandlersHover <>
|
||||
setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override
|
||||
setHandlersCompletion <>
|
||||
userHandlers <>
|
||||
setHandlersNotifications <> -- absolutely critical, join them with user notifications
|
||||
cancelHandler cancelRequest
|
||||
|
||||
@ -8,6 +8,7 @@ extra-deps:
|
||||
- hie-bios-0.3.0
|
||||
- ghc-lib-parser-8.8.1
|
||||
- ghc-lib-8.8.1
|
||||
- fuzzy-0.1.0.0
|
||||
nix:
|
||||
packages: [zlib]
|
||||
flags:
|
||||
|
||||
@ -6,5 +6,6 @@ extra-deps:
|
||||
- haskell-lsp-types-0.19.0.0
|
||||
- lsp-test-0.9.0.0
|
||||
- hie-bios-0.3.0
|
||||
- fuzzy-0.1.0.0
|
||||
nix:
|
||||
packages: [zlib]
|
||||
|
||||
@ -11,6 +11,7 @@ extra-deps:
|
||||
- filepattern-0.1.1
|
||||
- js-dgtable-0.5.2
|
||||
- hie-bios-0.3.0
|
||||
- fuzzy-0.1.0.0
|
||||
nix:
|
||||
packages: [zlib]
|
||||
allow-newer: true
|
||||
|
||||
@ -6,6 +6,7 @@ extra-deps:
|
||||
- haskell-lsp-types-0.19.0.0
|
||||
- lsp-test-0.9.0.0
|
||||
- hie-bios-0.3.0
|
||||
- fuzzy-0.1.0.0
|
||||
allow-newer: true
|
||||
nix:
|
||||
packages: [zlib]
|
||||
|
||||
@ -10,6 +10,7 @@ module Main (main) where
|
||||
import Control.Applicative.Combinators
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Char (toLower)
|
||||
import Data.Foldable
|
||||
import Development.IDE.GHC.Util
|
||||
@ -37,6 +38,7 @@ main = defaultMain $ testGroup "HIE"
|
||||
closeDoc doc
|
||||
void (message :: Session WorkDoneProgressEndNotification)
|
||||
, initializeResponseTests
|
||||
, completionTests
|
||||
, diagnosticTests
|
||||
, codeActionTests
|
||||
, codeLensesTests
|
||||
@ -59,7 +61,7 @@ initializeResponseTests = withResource acquire release tests where
|
||||
testGroup "initialize response capabilities"
|
||||
[ chk " text doc sync" _textDocumentSync tds
|
||||
, chk " hover" _hoverProvider (Just True)
|
||||
, chk "NO completion" _completionProvider Nothing
|
||||
, chk " completion" _completionProvider (Just $ CompletionOptions (Just False) Nothing Nothing)
|
||||
, chk "NO signature help" _signatureHelpProvider Nothing
|
||||
, chk " goto definition" _definitionProvider (Just True)
|
||||
, chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
|
||||
@ -960,6 +962,51 @@ thTests =
|
||||
expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
|
||||
]
|
||||
|
||||
completionTests :: TestTree
|
||||
completionTests
|
||||
= testGroup "completion"
|
||||
[ testSessionWait "variable" $ do
|
||||
let source = T.unlines ["module A where", "f = hea"]
|
||||
docId <- openDoc' "A.hs" "haskell" source
|
||||
compls <- getCompletions docId (Position 1 7)
|
||||
liftIO $ compls @?= [complItem "head" ["GHC.List", "base", "v", "head"] (Just CiFunction)]
|
||||
, testSessionWait "type" $ do
|
||||
let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
|
||||
docId <- openDoc' "A.hs" "haskell" source
|
||||
expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
|
||||
changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
|
||||
compls <- getCompletions docId (Position 2 7)
|
||||
liftIO $ compls @?=
|
||||
[ complItem "Bounded" ["GHC.Enum", "base", "t", "Bounded"] (Just CiClass)
|
||||
, complItem "Bool" ["GHC.Types", "ghc-prim", "t", "Bool"] (Just CiClass)
|
||||
]
|
||||
, testSessionWait "qualified" $ do
|
||||
let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
|
||||
docId <- openDoc' "A.hs" "haskell" source
|
||||
expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
|
||||
changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
|
||||
compls <- getCompletions docId (Position 2 15)
|
||||
liftIO $ compls @?= [complItem "head" ["GHC.List", "base", "v", "head"] (Just CiFunction)]
|
||||
]
|
||||
where
|
||||
complItem label xdata kind = CompletionItem
|
||||
{ _label = label
|
||||
, _kind = kind
|
||||
, _detail = Just "Prelude"
|
||||
, _documentation = Just (CompletionDocMarkup (MarkupContent {_kind = MkMarkdown, _value = ""}))
|
||||
, _deprecated = Nothing
|
||||
, _preselect = Nothing
|
||||
, _sortText = Nothing
|
||||
, _filterText = Nothing
|
||||
, _insertText = Nothing
|
||||
, _insertTextFormat = Just PlainText
|
||||
, _textEdit = Nothing
|
||||
, _additionalTextEdits = Nothing
|
||||
, _commitCharacters = Nothing
|
||||
, _command = Nothing
|
||||
, _xdata = Just (Aeson.toJSON (xdata :: [T.Text]))
|
||||
}
|
||||
|
||||
xfail :: TestTree -> String -> TestTree
|
||||
xfail = flip expectFailBecause
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user