@@ -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+ ]