From b52ee607f94092ab013b1b6f8c69bf26da19f6d1 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Thu, 19 Dec 2019 15:00:39 +0100 Subject: [PATCH] [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 04ca13b9d831eaaf013239cd8cbc49ea284b6de1. * "useWithStale" everywhere * Some suggestions by @cocreature * Adjust positions in the document * Start working on tests * Fix compilation problem * Fix tests * Better type tests --- ghcide.cabal | 5 + src/Development/IDE/Core/Completions.hs | 565 +++++++++++++++++++ src/Development/IDE/Core/CompletionsTypes.hs | 62 ++ src/Development/IDE/Core/RuleTypes.hs | 10 + src/Development/IDE/Core/Rules.hs | 15 + src/Development/IDE/LSP/Completions.hs | 46 ++ src/Development/IDE/LSP/LanguageServer.hs | 2 + stack-ghc-lib.yaml | 1 + stack.yaml | 1 + stack84.yaml | 1 + stack88.yaml | 1 + test/exe/Main.hs | 49 +- 12 files changed, 757 insertions(+), 1 deletion(-) create mode 100644 src/Development/IDE/Core/Completions.hs create mode 100644 src/Development/IDE/Core/CompletionsTypes.hs create mode 100644 src/Development/IDE/LSP/Completions.hs diff --git a/ghcide.cabal b/ghcide.cabal index a09fbecb..4b332ca3 100644 --- a/ghcide.cabal +++ b/ghcide.cabal @@ -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, diff --git a/src/Development/IDE/Core/Completions.hs b/src/Development/IDE/Core/Completions.hs new file mode 100644 index 00000000..38e6c522 --- /dev/null +++ b/src/Development/IDE/Core/Completions.hs @@ -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" + ] \ No newline at end of file diff --git a/src/Development/IDE/Core/CompletionsTypes.hs b/src/Development/IDE/Core/CompletionsTypes.hs new file mode 100644 index 00000000..c7f5b33c --- /dev/null +++ b/src/Development/IDE/Core/CompletionsTypes.hs @@ -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 \ No newline at end of file diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs index a5e82908..77903e70 100644 --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -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 \ No newline at end of file diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index 0aa29159..4f0c560c 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -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 ------------------------------------------------------------ diff --git a/src/Development/IDE/LSP/Completions.hs b/src/Development/IDE/LSP/Completions.hs new file mode 100644 index 00000000..1782fcee --- /dev/null +++ b/src/Development/IDE/LSP/Completions.hs @@ -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 + } diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs index 43df6449..846d82c6 100644 --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -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 diff --git a/stack-ghc-lib.yaml b/stack-ghc-lib.yaml index ad00de99..0c7d7997 100644 --- a/stack-ghc-lib.yaml +++ b/stack-ghc-lib.yaml @@ -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: diff --git a/stack.yaml b/stack.yaml index 5aec32f6..9a537210 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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] diff --git a/stack84.yaml b/stack84.yaml index 76aa5462..64e0185d 100644 --- a/stack84.yaml +++ b/stack84.yaml @@ -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 diff --git a/stack88.yaml b/stack88.yaml index b677430a..0e64159d 100644 --- a/stack88.yaml +++ b/stack88.yaml @@ -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] diff --git a/test/exe/Main.hs b/test/exe/Main.hs index c916f8da..cc5efab0 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -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