git.iko.soy/ghcide
on master help sign in
[WIP] Completion support (#227)
b52ee60Alejandro Serrano
ghcide.cabal+5
compare with master
unifiedsplit
@@ -39,6 +39,7 @@ library
39 deepseq,
39 deepseq,
40 directory,
40 directory,
41 extra,
41 extra,
42+ fuzzy,
42 filepath,
43 filepath,
43 hashable,
44 hashable,
44 haskell-lsp-types == 0.19.*,
45 haskell-lsp-types == 0.19.*,
@@ -96,6 +97,8 @@ library
96 include-dirs:
97 include-dirs:
97 include
98 include
98 exposed-modules:
99 exposed-modules:
100+ Development.IDE.Core.Completions
101+ Development.IDE.Core.CompletionsTypes
99 Development.IDE.Core.FileStore
102 Development.IDE.Core.FileStore
100 Development.IDE.Core.OfInterest
103 Development.IDE.Core.OfInterest
101 Development.IDE.Core.PositionMapping
104 Development.IDE.Core.PositionMapping
@@ -123,6 +126,7 @@ library
123 Development.IDE.GHC.Warnings
126 Development.IDE.GHC.Warnings
124 Development.IDE.Import.FindImports
127 Development.IDE.Import.FindImports
125 Development.IDE.LSP.CodeAction
128 Development.IDE.LSP.CodeAction
129+ Development.IDE.LSP.Completions
126 Development.IDE.LSP.HoverDefinition
130 Development.IDE.LSP.HoverDefinition
127 Development.IDE.LSP.Notifications
131 Development.IDE.LSP.Notifications
128 Development.IDE.Spans.AtPoint
132 Development.IDE.Spans.AtPoint
@@ -180,6 +184,7 @@ test-suite ghcide-tests
180 ghcide:ghcide,
184 ghcide:ghcide,
181 ghcide:ghcide-test-preprocessor
185 ghcide:ghcide-test-preprocessor
182 build-depends:
186 build-depends:
187+ aeson,
183 base,
188 base,
184 bytestring,
189 bytestring,
185 containers,
190 containers,
src/Development/IDE/Core/Completions.hsnew file+565
@@ -0,0 +1,565 @@
1+-- Mostly taken from "haskell-ide-engine"
2+module Development.IDE.Core.Completions (
3+ CachedCompletions
4+, cacheDataProducer
5+, WithSnippets(..)
6+,getCompletions
7+) where
8+
9+import Control.Applicative
10+import Data.Aeson
11+import Data.Aeson.Types
12+import Data.Char (isSpace)
13+import Data.Generics
14+import Data.List as List hiding (stripPrefix)
15+import qualified Data.Map as Map
16+import Data.Maybe (fromMaybe, mapMaybe)
17+import qualified Data.Text as T
18+import qualified Text.Fuzzy as Fuzzy
19+
20+import GHC
21+import Module
22+import HscTypes
23+import Name
24+import RdrName
25+import TcRnTypes
26+import Type
27+import Var
28+import Packages
29+import DynFlags
30+import ConLike
31+import DataCon
32+import SrcLoc as GHC
33+
34+import Language.Haskell.LSP.Types
35+import Language.Haskell.LSP.Types.Capabilities
36+import qualified Language.Haskell.LSP.VFS as VFS
37+import Development.IDE.Core.CompletionsTypes
38+import Development.IDE.Spans.Documentation
39+
40+-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
41+
42+data NameDetails
43+ = NameDetails Module OccName
44+ deriving (Eq)
45+
46+nsJSON :: NameSpace -> Value
47+nsJSON ns
48+ | isVarNameSpace ns = String "v"
49+ | isDataConNameSpace ns = String "c"
50+ | isTcClsNameSpace ns = String "t"
51+ | isTvNameSpace ns = String "z"
52+ | otherwise = error "namespace not recognized"
53+
54+parseNs :: Value -> Parser NameSpace
55+parseNs (String "v") = pure Name.varName
56+parseNs (String "c") = pure dataName
57+parseNs (String "t") = pure tcClsName
58+parseNs (String "z") = pure tvName
59+parseNs _ = mempty
60+
61+instance FromJSON NameDetails where
62+ parseJSON v@(Array _)
63+ = do
64+ [modname,modid,namesp,occname] <- parseJSON v
65+ mn <- parseJSON modname
66+ mid <- parseJSON modid
67+ ns <- parseNs namesp
68+ occn <- parseJSON occname
69+ pure $ NameDetails (mkModule (stringToUnitId mid) (mkModuleName mn)) (mkOccName ns occn)
70+ parseJSON _ = mempty
71+instance ToJSON NameDetails where
72+ toJSON (NameDetails mdl occ) = toJSON [toJSON mname,toJSON mid,nsJSON ns,toJSON occs]
73+ where
74+ mname = moduleNameString $ moduleName mdl
75+ mid = unitIdString $ moduleUnitId mdl
76+ ns = occNameSpace occ
77+ occs = occNameString occ
78+
79+safeTyThingId :: TyThing -> Maybe Id
80+safeTyThingId (AnId i) = Just i
81+safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc
82+safeTyThingId _ = Nothing
83+
84+-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
85+
86+-- | A context of a declaration in the program
87+-- e.g. is the declaration a type declaration or a value declaration
88+-- Used for determining which code completions to show
89+-- TODO: expand this with more contexts like classes or instances for
90+-- smarter code completion
91+data Context = TypeContext
92+ | ValueContext
93+ | ModuleContext String -- ^ module context with module name
94+ | ImportContext String -- ^ import context with module name
95+ | ImportListContext String -- ^ import list context with module name
96+ | ImportHidingContext String -- ^ import hiding context with module name
97+ | ExportContext -- ^ List of exported identifiers from the current module
98+ deriving (Show, Eq)
99+
100+-- | Generates a map of where the context is a type and where the context is a value
101+-- i.e. where are the value decls and the type decls
102+getCContext :: Position -> ParsedModule -> Maybe Context
103+getCContext pos pm
104+ | Just (L (RealSrcSpan r) modName) <- moduleHeader
105+ , pos `isInsideRange` r
106+ = Just (ModuleContext (moduleNameString modName))
107+
108+ | Just (L (RealSrcSpan r) _) <- exportList
109+ , pos `isInsideRange` r
110+ = Just ExportContext
111+
112+ | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl
113+ = Just ctx
114+
115+ | Just ctx <- something (Nothing `mkQ` importGo) imports
116+ = Just ctx
117+
118+ | otherwise
119+ = Nothing
120+
121+ where decl = hsmodDecls $ unLoc $ pm_parsed_source pm
122+ moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm
123+ exportList = hsmodExports $ unLoc $ pm_parsed_source pm
124+ imports = hsmodImports $ unLoc $ pm_parsed_source pm
125+
126+ go :: LHsDecl GhcPs -> Maybe Context
127+ go (L (RealSrcSpan r) SigD {})
128+ | pos `isInsideRange` r = Just TypeContext
129+ | otherwise = Nothing
130+ go (L (GHC.RealSrcSpan r) GHC.ValD {})
131+ | pos `isInsideRange` r = Just ValueContext
132+ | otherwise = Nothing
133+ go _ = Nothing
134+
135+ goInline :: GHC.LHsType GhcPs -> Maybe Context
136+ goInline (GHC.L (GHC.RealSrcSpan r) _)
137+ | pos `isInsideRange` r = Just TypeContext
138+ | otherwise = Nothing
139+ goInline _ = Nothing
140+
141+ p `isInsideRange` r = sp <= p && p <= ep
142+ where (sp, ep) = unpackRealSrcSpan r
143+
144+ -- | Converts from one based tuple
145+ toPos :: (Int,Int) -> Position
146+ toPos (l,c) = Position (l-1) (c-1)
147+
148+ unpackRealSrcSpan :: GHC.RealSrcSpan -> (Position, Position)
149+ unpackRealSrcSpan rspan =
150+ (toPos (l1,c1),toPos (l2,c2))
151+ where s = GHC.realSrcSpanStart rspan
152+ l1 = GHC.srcLocLine s
153+ c1 = GHC.srcLocCol s
154+ e = GHC.realSrcSpanEnd rspan
155+ l2 = GHC.srcLocLine e
156+ c2 = GHC.srcLocCol e
157+
158+ importGo :: GHC.LImportDecl GhcPs -> Maybe Context
159+ importGo (L (RealSrcSpan r) impDecl)
160+ | pos `isInsideRange` r
161+ = importInline importModuleName (ideclHiding impDecl)
162+ <|> Just (ImportContext importModuleName)
163+
164+ | otherwise = Nothing
165+ where importModuleName = moduleNameString $ unLoc $ ideclName impDecl
166+
167+ importGo _ = Nothing
168+
169+ importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context
170+ importInline modName (Just (True, L (RealSrcSpan r) _))
171+ | pos `isInsideRange` r = Just $ ImportHidingContext modName
172+ | otherwise = Nothing
173+ importInline modName (Just (False, L (RealSrcSpan r) _))
174+ | pos `isInsideRange` r = Just $ ImportListContext modName
175+ | otherwise = Nothing
176+ importInline _ _ = Nothing
177+
178+type CompItemResolveData
179+ = Maybe NameDetails
180+
181+occNameToComKind :: OccName -> CompletionItemKind
182+occNameToComKind oc
183+ | isVarOcc oc = CiFunction
184+ | isTcOcc oc = CiClass
185+ | isDataOcc oc = CiConstructor
186+ | otherwise = CiVariable
187+
188+mkCompl :: CompItem -> CompletionItem
189+mkCompl CI{origName,importedFrom,thingType,label,isInfix,docs} =
190+ CompletionItem label kind (Just $ maybe "" (<>"\n") typeText <> importedFrom)
191+ (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs)
192+ Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
193+ Nothing Nothing Nothing Nothing resolveData
194+ where kind = Just $ occNameToComKind $ occName origName
195+ resolveData = Just (toJSON nameDets)
196+ insertText = case isInfix of
197+ Nothing -> case getArgText <$> thingType of
198+ Nothing -> label
199+ Just argText -> label <> " " <> argText
200+ Just LeftSide -> label <> "`"
201+
202+ Just Surrounded -> label
203+ typeText
204+ | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)
205+ | otherwise = Nothing
206+ nameDets =
207+ case (thingType, nameModule_maybe origName) of
208+ (Just _,_) -> Nothing
209+ (Nothing, Nothing) -> Nothing
210+ (Nothing, Just mdl) -> Just (NameDetails mdl (nameOccName origName))
211+
212+stripForall :: T.Text -> T.Text
213+stripForall t
214+ | T.isPrefixOf "forall" t =
215+ -- We drop 2 to remove the '.' and the space after it
216+ T.drop 2 (T.dropWhile (/= '.') t)
217+ | otherwise = t
218+
219+getArgText :: Type -> T.Text
220+getArgText typ = argText
221+ where
222+ argTypes = getArgs typ
223+ argText :: T.Text
224+ argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes
225+ snippet :: Int -> Type -> T.Text
226+ snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"
227+ getArgs :: Type -> [Type]
228+ getArgs t
229+ | isPredTy t = []
230+ | isDictTy t = []
231+ | isForAllTy t = getArgs $ snd (splitForAllTys t)
232+ | isFunTy t =
233+ let (args, ret) = splitFunTys t
234+ in if isForAllTy ret
235+ then getArgs ret
236+ else Prelude.filter (not . isDictTy) args
237+ | isPiTy t = getArgs $ snd (splitPiTys t)
238+ | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)
239+ | otherwise = []
240+
241+mkModCompl :: T.Text -> CompletionItem
242+mkModCompl label =
243+ CompletionItem label (Just CiModule) Nothing
244+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing
245+ Nothing Nothing Nothing Nothing (Just $ toJSON resolveData)
246+ where resolveData :: CompItemResolveData
247+ resolveData = Nothing
248+
249+mkImportCompl :: T.Text -> T.Text -> CompletionItem
250+mkImportCompl enteredQual label =
251+ CompletionItem m (Just CiModule) (Just label)
252+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing
253+ Nothing Nothing Nothing Nothing Nothing
254+ where
255+ m = fromMaybe "" (T.stripPrefix enteredQual label)
256+
257+mkExtCompl :: T.Text -> CompletionItem
258+mkExtCompl label =
259+ CompletionItem label (Just CiKeyword) Nothing
260+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing
261+ Nothing Nothing Nothing Nothing Nothing
262+
263+mkPragmaCompl :: T.Text -> T.Text -> CompletionItem
264+mkPragmaCompl label insertText =
265+ CompletionItem label (Just CiKeyword) Nothing
266+ Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
267+ Nothing Nothing Nothing Nothing Nothing
268+
269+cacheDataProducer :: DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions
270+cacheDataProducer dflags tm tcs = do
271+ let parsedMod = tm_parsed_module tm
272+ curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod
273+ Just (_,limports,_,_) = tm_renamed_source tm
274+
275+ iDeclToModName :: ImportDecl name -> ModuleName
276+ iDeclToModName = unLoc . ideclName
277+
278+ showModName :: ModuleName -> T.Text
279+ showModName = T.pack . moduleNameString
280+
281+ asNamespace :: ImportDecl name -> ModuleName
282+ asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp)
283+ -- Full canonical names of imported modules
284+ importDeclerations = map unLoc limports
285+
286+ -- The list of all importable Modules from all packages
287+ moduleNames = map showModName (listVisibleModuleNames dflags)
288+
289+ -- The given namespaces for the imported modules (ie. full name, or alias if used)
290+ allModNamesAsNS = map (showModName . asNamespace) importDeclerations
291+
292+ typeEnv = tcg_type_env $ fst $ tm_internals_ tm
293+ rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm
294+ rdrElts = globalRdrEnvElts rdrEnv
295+
296+ getCompls :: [GlobalRdrElt] -> ([CompItem],QualCompls)
297+ getCompls = foldMap getComplsForOne
298+
299+ getComplsForOne :: GlobalRdrElt -> ([CompItem],QualCompls)
300+ getComplsForOne (GRE n _ True _) =
301+ case lookupTypeEnv typeEnv n of
302+ Just tt -> case safeTyThingId tt of
303+ Just var -> ([varToCompl var],mempty)
304+ Nothing -> ([toCompItem curMod n],mempty)
305+ Nothing -> ([toCompItem curMod n],mempty)
306+ getComplsForOne (GRE n _ False prov) =
307+ flip foldMap (map is_decl prov) $ \spec ->
308+ let unqual
309+ | is_qual spec = []
310+ | otherwise = compItem
311+ qual
312+ | is_qual spec = Map.singleton asMod compItem
313+ | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]
314+ compItem = [toCompItem (is_mod spec) n]
315+ asMod = showModName (is_as spec)
316+ origMod = showModName (is_mod spec)
317+ in (unqual,QualCompls qual)
318+
319+ varToCompl :: Var -> CompItem
320+ varToCompl var = CI name (showModName curMod) typ label Nothing docs
321+ where
322+ typ = Just $ varType var
323+ name = Var.varName var
324+ label = T.pack $ showGhc name
325+ docs = getDocumentation tcs name
326+
327+ toCompItem :: ModuleName -> Name -> CompItem
328+ toCompItem mn n =
329+ CI n (showModName mn) Nothing (T.pack $ showGhc n) Nothing (getDocumentation tcs n)
330+
331+ (unquals,quals) = getCompls rdrElts
332+
333+ return $ CC
334+ { allModNamesAsNS = allModNamesAsNS
335+ , unqualCompls = unquals
336+ , qualCompls = quals
337+ , importableModules = moduleNames
338+ }
339+
340+newtype WithSnippets = WithSnippets Bool
341+
342+toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem
343+toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
344+ | with && supported = x
345+ | otherwise = x { _insertTextFormat = Just PlainText
346+ , _insertText = Nothing
347+ }
348+ where supported = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
349+
350+-- | Returns the cached completions for the given module and position.
351+getCompletions :: CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
352+getCompletions CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }
353+ tm prefixInfo caps withSnippets = do
354+ let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo
355+ enteredQual = if T.null prefixModule then "" else prefixModule <> "."
356+ fullPrefix = enteredQual <> prefixText
357+
358+ -- default to value context if no explicit context
359+ context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)
360+
361+ {- correct the position by moving 'foo :: Int -> String -> '
362+ ^
363+ to 'foo :: Int -> String -> '
364+ ^
365+ -}
366+ pos =
367+ let Position l c = VFS.cursorPos prefixInfo
368+ typeStuff = [isSpace, (`elem` (">-." :: String))]
369+ stripTypeStuff = T.dropWhileEnd (\x -> any (\f -> f x) typeStuff)
370+ -- if oldPos points to
371+ -- foo -> bar -> baz
372+ -- ^
373+ -- Then only take the line up to there, discard '-> bar -> baz'
374+ partialLine = T.take c fullLine
375+ -- drop characters used when writing incomplete type sigs
376+ -- like '-> '
377+ d = T.length fullLine - T.length (stripTypeStuff partialLine)
378+ in Position l (c - d)
379+
380+ filtModNameCompls =
381+ map mkModCompl
382+ $ mapMaybe (T.stripPrefix enteredQual)
383+ $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS
384+
385+ filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False
386+ where
387+ isTypeCompl = isTcOcc . occName . origName
388+ -- completions specific to the current context
389+ ctxCompls' = case context of
390+ TypeContext -> filter isTypeCompl compls
391+ ValueContext -> filter (not . isTypeCompl) compls
392+ _ -> filter (not . isTypeCompl) compls
393+ -- Add whether the text to insert has backticks
394+ ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
395+
396+ infixCompls :: Maybe Backtick
397+ infixCompls = isUsedAsInfix fullLine prefixModule prefixText (VFS.cursorPos prefixInfo)
398+
399+ compls = if T.null prefixModule
400+ then unqualCompls
401+ else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls
402+
403+ filtListWith f list =
404+ [ f label
405+ | label <- Fuzzy.simpleFilter fullPrefix list
406+ , enteredQual `T.isPrefixOf` label
407+ ]
408+
409+ filtListWithSnippet f list suffix =
410+ [ toggleSnippets caps withSnippets (f label (snippet <> suffix))
411+ | (snippet, label) <- list
412+ , Fuzzy.test fullPrefix label
413+ ]
414+
415+ filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
416+ filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas
417+ filtOptsCompls = filtListWith mkExtCompl
418+
419+ stripLeading :: Char -> String -> String
420+ stripLeading _ [] = []
421+ stripLeading c (s:ss)
422+ | s == c = ss
423+ | otherwise = s:ss
424+
425+ result
426+ | "import " `T.isPrefixOf` fullLine
427+ = filtImportCompls
428+ | "{-# language" `T.isPrefixOf` T.toLower fullLine
429+ = filtOptsCompls languagesAndExts
430+ | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine
431+ = filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)
432+ | "{-# " `T.isPrefixOf` fullLine
433+ = filtPragmaCompls (pragmaSuffix fullLine)
434+ | otherwise
435+ = filtModNameCompls ++ map (toggleSnippets caps withSnippets
436+ . mkCompl . stripAutoGenerated) filtCompls
437+
438+ return result
439+
440+-- The supported languages and extensions
441+languagesAndExts :: [T.Text]
442+languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions
443+
444+-- ---------------------------------------------------------------------
445+-- helper functions for pragmas
446+-- ---------------------------------------------------------------------
447+
448+validPragmas :: [(T.Text, T.Text)]
449+validPragmas =
450+ [ ("LANGUAGE ${1:extension}" , "LANGUAGE")
451+ , ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC")
452+ , ("INLINE ${1:function}" , "INLINE")
453+ , ("NOINLINE ${1:function}" , "NOINLINE")
454+ , ("INLINABLE ${1:function}" , "INLINABLE")
455+ , ("WARNING ${1:message}" , "WARNING")
456+ , ("DEPRECATED ${1:message}" , "DEPRECATED")
457+ , ("ANN ${1:annotation}" , "ANN")
458+ , ("RULES" , "RULES")
459+ , ("SPECIALIZE ${1:function}" , "SPECIALIZE")
460+ , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE")
461+ ]
462+
463+pragmaSuffix :: T.Text -> T.Text
464+pragmaSuffix fullLine
465+ | "}" `T.isSuffixOf` fullLine = mempty
466+ | otherwise = " #-}"
467+
468+-- ---------------------------------------------------------------------
469+-- helper functions for infix backticks
470+-- ---------------------------------------------------------------------
471+
472+hasTrailingBacktick :: T.Text -> Position -> Bool
473+hasTrailingBacktick line Position { _character }
474+ | T.length line > _character = (line `T.index` _character) == '`'
475+ | otherwise = False
476+
477+isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick
478+isUsedAsInfix line prefixMod prefixText pos
479+ | hasClosingBacktick && hasOpeningBacktick = Just Surrounded
480+ | hasOpeningBacktick = Just LeftSide
481+ | otherwise = Nothing
482+ where
483+ hasOpeningBacktick = openingBacktick line prefixMod prefixText pos
484+ hasClosingBacktick = hasTrailingBacktick line pos
485+
486+openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool
487+openingBacktick line prefixModule prefixText Position { _character }
488+ | backtickIndex < 0 = False
489+ | otherwise = (line `T.index` backtickIndex) == '`'
490+ where
491+ backtickIndex :: Int
492+ backtickIndex =
493+ let
494+ prefixLength = T.length prefixText
495+ moduleLength = if prefixModule == ""
496+ then 0
497+ else T.length prefixModule + 1 {- Because of "." -}
498+ in
499+ -- Points to the first letter of either the module or prefix text
500+ _character - (prefixLength + moduleLength) - 1
501+
502+
503+-- ---------------------------------------------------------------------
504+
505+-- | Under certain circumstance GHC generates some extra stuff that we
506+-- don't want in the autocompleted symbols
507+stripAutoGenerated :: CompItem -> CompItem
508+stripAutoGenerated ci =
509+ ci {label = stripPrefix (label ci)}
510+ {- When e.g. DuplicateRecordFields is enabled, compiler generates
511+ names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors
512+ https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
513+ -}
514+
515+-- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.
516+
517+stripPrefix :: T.Text -> T.Text
518+stripPrefix name = T.takeWhile (/=':') $ go prefixes
519+ where
520+ go [] = name
521+ go (p:ps)
522+ | T.isPrefixOf p name = T.drop (T.length p) name
523+ | otherwise = go ps
524+
525+-- | Prefixes that can occur in a GHC OccName
526+prefixes :: [T.Text]
527+prefixes =
528+ [
529+ -- long ones
530+ "$con2tag_"
531+ , "$tag2con_"
532+ , "$maxtag_"
533+
534+ -- four chars
535+ , "$sel:"
536+ , "$tc'"
537+
538+ -- three chars
539+ , "$dm"
540+ , "$co"
541+ , "$tc"
542+ , "$cp"
543+ , "$fx"
544+
545+ -- two chars
546+ , "$W"
547+ , "$w"
548+ , "$m"
549+ , "$b"
550+ , "$c"
551+ , "$d"
552+ , "$i"
553+ , "$s"
554+ , "$f"
555+ , "$r"
556+ , "C:"
557+ , "N:"
558+ , "D:"
559+ , "$p"
560+ , "$L"
561+ , "$f"
562+ , "$t"
563+ , "$c"
564+ , "$m"
565+ ]
src/Development/IDE/Core/CompletionsTypes.hsnew file+62
@@ -0,0 +1,62 @@
1+module Development.IDE.Core.CompletionsTypes (
2+ module Development.IDE.Core.CompletionsTypes
3+) where
4+
5+import Control.DeepSeq
6+import qualified Data.Map as Map
7+import qualified Data.Text as T
8+
9+import GHC
10+import Outputable
11+import DynFlags
12+
13+-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs
14+
15+showGhc :: Outputable a => a -> String
16+showGhc = showPpr unsafeGlobalDynFlags
17+
18+data Backtick = Surrounded | LeftSide deriving Show
19+data CompItem = CI
20+ { origName :: Name -- ^ Original name, such as Maybe, //, or find.
21+ , importedFrom :: T.Text -- ^ From where this item is imported from.
22+ , thingType :: Maybe Type -- ^ Available type information.
23+ , label :: T.Text -- ^ Label to display to the user.
24+ , isInfix :: Maybe Backtick -- ^ Did the completion happen
25+ -- in the context of an infix notation.
26+ , docs :: [T.Text] -- ^ Available documentation.
27+ }
28+instance Show CompItem where
29+ show CI { .. } = "CompItem { origName = \"" ++ showGhc origName ++ "\""
30+ ++ ", importedFrom = " ++ show importedFrom
31+ ++ ", thingType = " ++ show (fmap showGhc thingType)
32+ ++ ", label = " ++ show label
33+ ++ ", isInfix = " ++ show isInfix
34+ ++ ", docs = " ++ show docs
35+ ++ " } "
36+instance Eq CompItem where
37+ ci1 == ci2 = origName ci1 == origName ci2
38+instance Ord CompItem where
39+ compare ci1 ci2 = origName ci1 `compare` origName ci2
40+
41+-- Associates a module's qualifier with its members
42+newtype QualCompls
43+ = QualCompls { getQualCompls :: Map.Map T.Text [CompItem] }
44+ deriving Show
45+instance Semigroup QualCompls where
46+ (QualCompls a) <> (QualCompls b) = QualCompls $ Map.unionWith (++) a b
47+instance Monoid QualCompls where
48+ mempty = QualCompls Map.empty
49+ mappend = (Prelude.<>)
50+
51+-- | End result of the completions
52+data CachedCompletions = CC
53+ { allModNamesAsNS :: [T.Text] -- ^ All module names in scope.
54+ -- Prelude is a single module
55+ , unqualCompls :: [CompItem] -- ^ All Possible completion items
56+ , qualCompls :: QualCompls -- ^ Completion items associated to
57+ -- to a specific module name.
58+ , importableModules :: [T.Text] -- ^ All modules that may be imported.
59+ } deriving Show
60+
61+instance NFData CachedCompletions where
62+ rnf = rwhnf
src/Development/IDE/Core/RuleTypes.hs+10
@@ -27,6 +27,7 @@ import Module (InstalledUnitId)
27import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
27import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
28import Development.IDE.GHC.Compat
28import Development.IDE.GHC.Compat
29
29
30+import Development.IDE.Core.CompletionsTypes
30import Development.IDE.Spans.Type
31import Development.IDE.Spans.Type
31
32
32
33
@@ -85,6 +86,9 @@ type instance RuleResult ReportImportCycles = ()
85-- | Read the given HIE file.
86-- | Read the given HIE file.
86type instance RuleResult GetHieFile = HieFile
87type instance RuleResult GetHieFile = HieFile
87
88
89+-- | Produce completions info for a file
90+type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult)
91+
88
92
89data GetParsedModule = GetParsedModule
93data GetParsedModule = GetParsedModule
90 deriving (Eq, Show, Typeable, Generic)
94 deriving (Eq, Show, Typeable, Generic)
@@ -153,3 +157,9 @@ data GetHieFile = GetHieFile FilePath
153instance Hashable GetHieFile
157instance Hashable GetHieFile
154instance NFData GetHieFile
158instance NFData GetHieFile
155instance Binary GetHieFile
159instance Binary GetHieFile
160+
161+data ProduceCompletions = ProduceCompletions
162+ deriving (Eq, Show, Typeable, Generic)
163+instance Hashable ProduceCompletions
164+instance NFData ProduceCompletions
165+instance Binary ProduceCompletions
src/Development/IDE/Core/Rules.hs+15
@@ -32,6 +32,7 @@ import Control.Monad
32import Control.Monad.Trans.Class
32import Control.Monad.Trans.Class
33import Control.Monad.Trans.Maybe
33import Control.Monad.Trans.Maybe
34import Development.IDE.Core.Compile
34import Development.IDE.Core.Compile
35+import Development.IDE.Core.Completions
35import Development.IDE.Types.Options
36import Development.IDE.Types.Options
36import Development.IDE.Spans.Calculate
37import Development.IDE.Spans.Calculate
37import Development.IDE.Import.DependencyInformation
38import Development.IDE.Import.DependencyInformation
@@ -304,6 +305,19 @@ generateCoreRule :: Rules ()
304generateCoreRule =
305generateCoreRule =
305 define $ \GenerateCore -> generateCore
306 define $ \GenerateCore -> generateCore
306
307
308+produceCompletions :: Rules ()
309+produceCompletions =
310+ define $ \ProduceCompletions file -> do
311+ deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
312+ tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
313+ tm <- fmap fst <$> useWithStale TypeCheck file
314+ dflags <- fmap (hsc_dflags . hscEnv . fst) <$> useWithStale GhcSession file
315+ case (tm, dflags) of
316+ (Just tm', Just dflags') -> do
317+ cdata <- liftIO $ cacheDataProducer dflags' (tmrModule tm') (map tmrModule tms)
318+ return ([], Just (cdata, tm'))
319+ _ -> return ([], Nothing)
320+
307generateByteCodeRule :: Rules ()
321generateByteCodeRule :: Rules ()
308generateByteCodeRule =
322generateByteCodeRule =
309 define $ \GenerateByteCode file -> do
323 define $ \GenerateByteCode file -> do
@@ -361,6 +375,7 @@ mainRule = do
361 generateByteCodeRule
375 generateByteCodeRule
362 loadGhcSession
376 loadGhcSession
363 getHieFileRule
377 getHieFileRule
378+ produceCompletions
364
379
365------------------------------------------------------------
380------------------------------------------------------------
366
381
src/Development/IDE/LSP/Completions.hsnew file+46
@@ -0,0 +1,46 @@
1+module Development.IDE.LSP.Completions (
2+ setHandlersCompletion
3+) where
4+
5+import Language.Haskell.LSP.Messages
6+import Language.Haskell.LSP.Types
7+import qualified Language.Haskell.LSP.Core as LSP
8+import qualified Language.Haskell.LSP.VFS as VFS
9+import Language.Haskell.LSP.Types.Capabilities
10+
11+import Development.IDE.Core.Service
12+import Development.IDE.Core.Completions
13+import Development.IDE.Types.Location
14+import Development.IDE.Core.PositionMapping
15+import Development.IDE.Core.RuleTypes
16+import Development.IDE.Core.Shake
17+import Development.IDE.LSP.Server
18+
19+-- | Generate code actions.
20+getCompletionsLSP
21+ :: LSP.LspFuncs ()
22+ -> IdeState
23+ -> CompletionParams
24+ -> IO CompletionResponseResult
25+getCompletionsLSP lsp ide CompletionParams{_textDocument=TextDocumentIdentifier uri,_position=position} = do
26+ contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
27+ case (contents, uriToFilePath' uri) of
28+ (Just cnts, Just path) -> do
29+ let npath = toNormalizedFilePath path
30+ compls <- runAction ide (useWithStale ProduceCompletions npath)
31+ case compls of
32+ Just ((cci', tm'), mapping) -> do
33+ let position' = fromCurrentPosition mapping position
34+ pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
35+ case pfix of
36+ Just pfix' -> do
37+ let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
38+ Completions . List <$> getCompletions cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)
39+ _ -> return (Completions $ List [])
40+ _ -> return (Completions $ List [])
41+ _ -> return (Completions $ List [])
42+
43+setHandlersCompletion :: PartialHandlers
44+setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
45+ LSP.completionHandler = withResponse RspCompletion getCompletionsLSP
46+ }
src/Development/IDE/LSP/LanguageServer.hs+2
@@ -30,6 +30,7 @@ import Control.Monad.Extra
30
30
31import Development.IDE.LSP.HoverDefinition
31import Development.IDE.LSP.HoverDefinition
32import Development.IDE.LSP.CodeAction
32import Development.IDE.LSP.CodeAction
33+import Development.IDE.LSP.Completions
33import Development.IDE.LSP.Notifications
34import Development.IDE.LSP.Notifications
34import Development.IDE.Core.Service
35import Development.IDE.Core.Service
35import Development.IDE.Types.Logger
36import Development.IDE.Types.Logger
@@ -97,6 +98,7 @@ runLanguageServer options userHandlers getIdeState = do
97 setHandlersIgnore <> -- least important
98 setHandlersIgnore <> -- least important
98 setHandlersDefinition <> setHandlersHover <>
99 setHandlersDefinition <> setHandlersHover <>
99 setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override
100 setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override
101+ setHandlersCompletion <>
100 userHandlers <>
102 userHandlers <>
101 setHandlersNotifications <> -- absolutely critical, join them with user notifications
103 setHandlersNotifications <> -- absolutely critical, join them with user notifications
102 cancelHandler cancelRequest
104 cancelHandler cancelRequest
stack-ghc-lib.yaml+1
@@ -8,6 +8,7 @@ extra-deps:
8- hie-bios-0.3.0
8- hie-bios-0.3.0
9- ghc-lib-parser-8.8.1
9- ghc-lib-parser-8.8.1
10- ghc-lib-8.8.1
10- ghc-lib-8.8.1
11+- fuzzy-0.1.0.0
11nix:
12nix:
12 packages: [zlib]
13 packages: [zlib]
13flags:
14flags:
stack.yaml+1
@@ -6,5 +6,6 @@ extra-deps:
6- haskell-lsp-types-0.19.0.0
6- haskell-lsp-types-0.19.0.0
7- lsp-test-0.9.0.0
7- lsp-test-0.9.0.0
8- hie-bios-0.3.0
8- hie-bios-0.3.0
9+- fuzzy-0.1.0.0
9nix:
10nix:
10 packages: [zlib]
11 packages: [zlib]
stack84.yaml+1
@@ -11,6 +11,7 @@ extra-deps:
11- filepattern-0.1.1
11- filepattern-0.1.1
12- js-dgtable-0.5.2
12- js-dgtable-0.5.2
13- hie-bios-0.3.0
13- hie-bios-0.3.0
14+- fuzzy-0.1.0.0
14nix:
15nix:
15 packages: [zlib]
16 packages: [zlib]
16allow-newer: true
17allow-newer: true
stack88.yaml+1
@@ -6,6 +6,7 @@ extra-deps:
6- haskell-lsp-types-0.19.0.0
6- haskell-lsp-types-0.19.0.0
7- lsp-test-0.9.0.0
7- lsp-test-0.9.0.0
8- hie-bios-0.3.0
8- hie-bios-0.3.0
9+- fuzzy-0.1.0.0
9allow-newer: true
10allow-newer: true
10nix:
11nix:
11 packages: [zlib]
12 packages: [zlib]
test/exe/Main.hs+48−1
@@ -10,6 +10,7 @@ module Main (main) where
10import Control.Applicative.Combinators
10import Control.Applicative.Combinators
11import Control.Monad
11import Control.Monad
12import Control.Monad.IO.Class (liftIO)
12import Control.Monad.IO.Class (liftIO)
13+import qualified Data.Aeson as Aeson
13import Data.Char (toLower)
14import Data.Char (toLower)
14import Data.Foldable
15import Data.Foldable
15import Development.IDE.GHC.Util
16import Development.IDE.GHC.Util
@@ -37,6 +38,7 @@ main = defaultMain $ testGroup "HIE"
37 closeDoc doc
38 closeDoc doc
38 void (message :: Session WorkDoneProgressEndNotification)
39 void (message :: Session WorkDoneProgressEndNotification)
39 , initializeResponseTests
40 , initializeResponseTests
41+ , completionTests
40 , diagnosticTests
42 , diagnosticTests
41 , codeActionTests
43 , codeActionTests
42 , codeLensesTests
44 , codeLensesTests
@@ -59,7 +61,7 @@ initializeResponseTests = withResource acquire release tests where
59 testGroup "initialize response capabilities"
61 testGroup "initialize response capabilities"
60 [ chk " text doc sync" _textDocumentSync tds
62 [ chk " text doc sync" _textDocumentSync tds
61 , chk " hover" _hoverProvider (Just True)
63 , chk " hover" _hoverProvider (Just True)
62− , chk "NO completion" _completionProvider Nothing
64+ , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) Nothing Nothing)
63 , chk "NO signature help" _signatureHelpProvider Nothing
65 , chk "NO signature help" _signatureHelpProvider Nothing
64 , chk " goto definition" _definitionProvider (Just True)
66 , chk " goto definition" _definitionProvider (Just True)
65 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
67 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
@@ -960,6 +962,51 @@ thTests =
960 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
962 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
961 ]
963 ]
962
964
965+completionTests :: TestTree
966+completionTests
967+ = testGroup "completion"
968+ [ testSessionWait "variable" $ do
969+ let source = T.unlines ["module A where", "f = hea"]
970+ docId <- openDoc' "A.hs" "haskell" source
971+ compls <- getCompletions docId (Position 1 7)
972+ liftIO $ compls @?= [complItem "head" ["GHC.List", "base", "v", "head"] (Just CiFunction)]
973+ , testSessionWait "type" $ do
974+ let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
975+ docId <- openDoc' "A.hs" "haskell" source
976+ expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
977+ changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
978+ compls <- getCompletions docId (Position 2 7)
979+ liftIO $ compls @?=
980+ [ complItem "Bounded" ["GHC.Enum", "base", "t", "Bounded"] (Just CiClass)
981+ , complItem "Bool" ["GHC.Types", "ghc-prim", "t", "Bool"] (Just CiClass)
982+ ]
983+ , testSessionWait "qualified" $ do
984+ let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
985+ docId <- openDoc' "A.hs" "haskell" source
986+ expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
987+ changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
988+ compls <- getCompletions docId (Position 2 15)
989+ liftIO $ compls @?= [complItem "head" ["GHC.List", "base", "v", "head"] (Just CiFunction)]
990+ ]
991+ where
992+ complItem label xdata kind = CompletionItem
993+ { _label = label
994+ , _kind = kind
995+ , _detail = Just "Prelude"
996+ , _documentation = Just (CompletionDocMarkup (MarkupContent {_kind = MkMarkdown, _value = ""}))
997+ , _deprecated = Nothing
998+ , _preselect = Nothing
999+ , _sortText = Nothing
1000+ , _filterText = Nothing
1001+ , _insertText = Nothing
1002+ , _insertTextFormat = Just PlainText
1003+ , _textEdit = Nothing
1004+ , _additionalTextEdits = Nothing
1005+ , _commitCharacters = Nothing
1006+ , _command = Nothing
1007+ , _xdata = Just (Aeson.toJSON (xdata :: [T.Text]))
1008+ }
1009+
963xfail :: TestTree -> String -> TestTree
1010xfail :: TestTree -> String -> TestTree
964xfail = flip expectFailBecause
1011xfail = flip expectFailBecause
965
1012