1{-# LANGUAGE CPP        #-}
2{-# LANGUAGE GADTs      #-}
3{-# LANGUAGE MultiWayIf #-}
4
5
6-- Mostly taken from "haskell-ide-engine"
7module Development.IDE.Plugin.Completions.Logic (
8  CachedCompletions
9, cacheDataProducer
10, localCompletionsForParsedModule
11, getCompletions
12, fromIdentInfo
13) where
14
15import           Control.Applicative
16import           Data.Char                                (isUpper)
17import           Data.Generics
18import           Data.List.Extra                          as List hiding
19                                                                  (stripPrefix)
20import qualified Data.Map                                 as Map
21
22import           Data.Maybe                               (fromMaybe, isJust,
23                                                           isNothing,
24                                                           listToMaybe,
25                                                           mapMaybe)
26import qualified Data.Text                                as T
27import qualified Text.Fuzzy                               as Fuzzy
28
29import           HscTypes
30import           Name
31import           RdrName
32import           Type
33#if MIN_VERSION_ghc(8,10,0)
34import           Coercion
35import           Pair
36import           Predicate                                (isDictTy)
37#endif
38
39import           ConLike
40import           Control.Monad
41import           Data.Aeson                               (ToJSON (toJSON))
42import           Data.Either                              (fromRight)
43import           Data.Functor
44import qualified Data.HashMap.Strict                      as HM
45import qualified Data.Set                                 as Set
46import qualified Data.HashSet                             as HashSet
47import           Development.IDE.Core.Compile
48import           Development.IDE.Core.PositionMapping
49import           Development.IDE.GHC.Compat               as GHC
50import           Development.IDE.GHC.Error
51import           Development.IDE.GHC.Util
52import           Development.IDE.Plugin.Completions.Types
53import           Development.IDE.Spans.Common
54import           Development.IDE.Spans.Documentation
55import           Development.IDE.Spans.LocalBindings
56import           Development.IDE.Types.Exports
57import           Development.IDE.Types.HscEnvEq
58import           Development.IDE.Types.Options
59import           GhcPlugins                               (flLabel, unpackFS)
60import           Ide.PluginUtils                          (mkLspCommand)
61import           Ide.Types                                (CommandId (..),
62                                                           PluginId)
63import           Language.LSP.Types
64import           Language.LSP.Types.Capabilities
65import qualified Language.LSP.VFS                         as VFS
66import           Outputable                               (Outputable)
67import           TyCoRep
68
69-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
70
71-- | A context of a declaration in the program
72-- e.g. is the declaration a type declaration or a value declaration
73-- Used for determining which code completions to show
74-- TODO: expand this with more contexts like classes or instances for
75-- smarter code completion
76data Context = TypeContext
77             | ValueContext
78             | ModuleContext String -- ^ module context with module name
79             | ImportContext String -- ^ import context with module name
80             | ImportListContext String -- ^ import list context with module name
81             | ImportHidingContext String -- ^ import hiding context with module name
82             | ExportContext -- ^ List of exported identifiers from the current module
83  deriving (Show, Eq)
84
85-- | Generates a map of where the context is a type and where the context is a value
86-- i.e. where are the value decls and the type decls
87getCContext :: Position -> ParsedModule -> Maybe Context
88getCContext pos pm
89  | Just (L r modName) <- moduleHeader
90  , pos `isInsideSrcSpan` r
91  = Just (ModuleContext (moduleNameString modName))
92
93  | Just (L r _) <- exportList
94  , pos `isInsideSrcSpan` r
95  = Just ExportContext
96
97  | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl
98  = Just ctx
99
100  | Just ctx <- something (Nothing `mkQ` importGo) imports
101  = Just ctx
102
103  | otherwise
104  = Nothing
105
106  where decl = hsmodDecls $ unLoc $ pm_parsed_source pm
107        moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm
108        exportList = hsmodExports $ unLoc $ pm_parsed_source pm
109        imports = hsmodImports $ unLoc $ pm_parsed_source pm
110
111        go :: LHsDecl GhcPs -> Maybe Context
112        go (L r SigD {})
113          | pos `isInsideSrcSpan` r = Just TypeContext
114          | otherwise = Nothing
115        go (L r GHC.ValD {})
116          | pos `isInsideSrcSpan` r = Just ValueContext
117          | otherwise = Nothing
118        go _ = Nothing
119
120        goInline :: GHC.LHsType GhcPs -> Maybe Context
121        goInline (GHC.L r _)
122          | pos `isInsideSrcSpan` r = Just TypeContext
123        goInline _ = Nothing
124
125        importGo :: GHC.LImportDecl GhcPs -> Maybe Context
126        importGo (L r impDecl)
127          | pos `isInsideSrcSpan` r
128          = importInline importModuleName (ideclHiding impDecl)
129          <|> Just (ImportContext importModuleName)
130
131          | otherwise = Nothing
132          where importModuleName = moduleNameString $ unLoc $ ideclName impDecl
133
134        importInline :: String -> Maybe (Bool,  GHC.Located [LIE GhcPs]) -> Maybe Context
135        importInline modName (Just (True, L r _))
136          | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName
137          | otherwise = Nothing
138        importInline modName (Just (False, L r _))
139          | pos `isInsideSrcSpan` r = Just $ ImportListContext modName
140          | otherwise = Nothing
141        importInline _ _ = Nothing
142
143occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind
144occNameToComKind ty oc
145  | isVarOcc  oc = case occNameString oc of
146                     i:_ | isUpper i -> CiConstructor
147                     _               -> CiFunction
148  | isTcOcc   oc = case ty of
149                     Just t
150                       | "Constraint" `T.isSuffixOf` t
151                       -> CiInterface
152                     _ -> CiStruct
153  | isDataOcc oc = CiConstructor
154  | otherwise    = CiVariable
155
156
157showModName :: ModuleName -> T.Text
158showModName = T.pack . moduleNameString
159
160-- mkCompl :: IdeOptions -> CompItem -> CompletionItem
161-- mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} =
162--   CompletionItem label kind (List []) ((colon <>) <$> typeText)
163--     (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')
164--     Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
165--     Nothing Nothing Nothing Nothing Nothing
166
167mkCompl :: PluginId -> IdeOptions -> CompItem -> IO CompletionItem
168mkCompl
169  pId
170  IdeOptions {..}
171  CI
172    { compKind,
173      isInfix,
174      insertText,
175      importedFrom,
176      typeText,
177      label,
178      docs,
179      additionalTextEdits
180    } = do
181  mbCommand <- mkAdditionalEditsCommand pId `traverse` additionalTextEdits
182  let ci = CompletionItem
183                 {_label = label,
184                  _kind = kind,
185                  _tags = Nothing,
186                  _detail = (colon <>) <$> typeText,
187                  _documentation = documentation,
188                  _deprecated = Nothing,
189                  _preselect = Nothing,
190                  _sortText = Nothing,
191                  _filterText = Nothing,
192                  _insertText = Just insertText,
193                  _insertTextFormat = Just Snippet,
194                  _insertTextMode = Nothing,
195                  _textEdit = Nothing,
196                  _additionalTextEdits = Nothing,
197                  _commitCharacters = Nothing,
198                  _command = mbCommand,
199                  _xdata = Nothing}
200  return $ removeSnippetsWhen (isJust isInfix) ci
201
202  where kind = Just compKind
203        docs' = imported : spanDocToMarkdown docs
204        imported = case importedFrom of
205          Left pos  -> "*Defined at '" <> ppr pos <> "'*\n'"
206          Right mod -> "*Defined in '" <> mod <> "'*\n"
207        colon = if optNewColonConvention then ": " else ":: "
208        documentation = Just $ CompletionDocMarkup $
209                        MarkupContent MkMarkdown $
210                        T.intercalate sectionSeparator docs'
211
212mkAdditionalEditsCommand :: PluginId -> ExtendImport -> IO Command
213mkAdditionalEditsCommand pId edits = pure $
214  mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits])
215
216mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
217mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI {..}
218  where
219    compKind = occNameToComKind typeText origName
220    importedFrom = Right $ showModName origMod
221    isTypeCompl = isTcOcc origName
222    label = stripPrefix $ showGhc origName
223    insertText = case isInfix of
224            Nothing -> case getArgText <$> thingType of
225                            Nothing      -> label
226                            Just argText -> label <> " " <> argText
227            Just LeftSide -> label <> "`"
228
229            Just Surrounded -> label
230    typeText
231          | Just t <- thingType = Just . stripForall $ showGhc t
232          | otherwise = Nothing
233    additionalTextEdits =
234      imp <&> \x ->
235        ExtendImport
236          { doc,
237            thingParent,
238            importName = showModName $ unLoc $ ideclName $ unLoc x,
239            importQual = getImportQual x,
240            newThing = showNameWithoutUniques origName
241          }
242
243    stripForall :: T.Text -> T.Text
244    stripForall t
245      | T.isPrefixOf "forall" t =
246        -- We drop 2 to remove the '.' and the space after it
247        T.drop 2 (T.dropWhile (/= '.') t)
248      | otherwise               = t
249
250    getArgText :: Type -> T.Text
251    getArgText typ = argText
252      where
253        argTypes = getArgs typ
254        argText :: T.Text
255        argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes
256        snippet :: Int -> Type -> T.Text
257        snippet i t = case t of
258            (TyVarTy _)     -> noParensSnippet
259            (LitTy _)       -> noParensSnippet
260            (TyConApp _ []) -> noParensSnippet
261            _               -> snippetText i ("(" <> showGhc t <> ")")
262            where
263                noParensSnippet = snippetText i (showGhc t)
264                snippetText i t = "${" <> T.pack (show i) <> ":" <> t <> "}"
265        getArgs :: Type -> [Type]
266        getArgs t
267          | isPredTy t = []
268          | isDictTy t = []
269          | isForAllTy t = getArgs $ snd (splitForAllTys t)
270          | isFunTy t =
271            let (args, ret) = splitFunTys t
272              in if isForAllTy ret
273                  then getArgs ret
274                  else Prelude.filter (not . isDictTy) $ map scaledThing args
275          | isPiTy t = getArgs $ snd (splitPiTys t)
276#if MIN_VERSION_ghc(8,10,0)
277          | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t
278          = getArgs t
279#else
280          | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)
281#endif
282          | otherwise = []
283
284mkModCompl :: T.Text -> CompletionItem
285mkModCompl label =
286  CompletionItem label (Just CiModule) Nothing Nothing
287    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
288    Nothing Nothing Nothing Nothing Nothing Nothing
289
290mkModuleFunctionImport :: T.Text -> T.Text -> CompletionItem
291mkModuleFunctionImport moduleName label =
292  CompletionItem label (Just CiFunction) Nothing (Just moduleName)
293    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
294    Nothing Nothing Nothing Nothing Nothing Nothing
295
296mkImportCompl :: T.Text -> T.Text -> CompletionItem
297mkImportCompl enteredQual label =
298  CompletionItem m (Just CiModule) Nothing (Just label)
299    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
300    Nothing Nothing Nothing Nothing Nothing Nothing
301  where
302    m = fromMaybe "" (T.stripPrefix enteredQual label)
303
304mkExtCompl :: T.Text -> CompletionItem
305mkExtCompl label =
306  CompletionItem label (Just CiKeyword) Nothing Nothing
307    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
308    Nothing Nothing Nothing Nothing Nothing Nothing
309
310
311fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem
312fromIdentInfo doc IdentInfo{..} q = CI
313  { compKind= occNameToComKind Nothing name
314  , insertText=rendered
315  , importedFrom=Right moduleNameText
316  , typeText=Nothing
317  , label=rendered
318  , isInfix=Nothing
319  , docs=emptySpanDoc
320  , isTypeCompl= not isDatacon && isUpper (T.head rendered)
321  , additionalTextEdits= Just $
322        ExtendImport
323          { doc,
324            thingParent = parent,
325            importName = moduleNameText,
326            importQual = q,
327            newThing = rendered
328          }
329  }
330
331cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions
332cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do
333  let
334      packageState = hscEnv env
335      curModName = moduleName curMod
336
337      importMap = Map.fromList [ (l, imp) | imp@(L (OldRealSrcSpan l) _) <- limports ]
338
339      iDeclToModName :: ImportDecl name -> ModuleName
340      iDeclToModName = unLoc . ideclName
341
342      asNamespace :: ImportDecl name -> ModuleName
343      asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp)
344      -- Full canonical names of imported modules
345      importDeclerations = map unLoc limports
346
347
348      -- The given namespaces for the imported modules (ie. full name, or alias if used)
349      allModNamesAsNS = map (showModName . asNamespace) importDeclerations
350
351      rdrElts = globalRdrEnvElts globalEnv
352
353      foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
354      foldMapM f xs = foldr step return xs mempty where
355        step x r z = f x >>= \y -> r $! z `mappend` y
356
357      getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls)
358      getCompls = foldMapM getComplsForOne
359
360      getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)
361      getComplsForOne (GRE n par True _) =
362          (, mempty) <$> toCompItem par curMod curModName n Nothing
363      getComplsForOne (GRE n par False prov) =
364        flip foldMapM (map is_decl prov) $ \spec -> do
365          let originalImportDecl = do
366                -- we don't want to extend import if it's already in scope
367                guard . null $ lookupGRE_Name inScopeEnv n
368                -- or if it doesn't have a real location
369                loc <- realSpan $ is_dloc spec
370                Map.lookup loc importMap
371          compItem <- toCompItem par curMod (is_mod spec) n originalImportDecl
372          let unqual
373                | is_qual spec = []
374                | otherwise = compItem
375              qual
376                | is_qual spec = Map.singleton asMod compItem
377                | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]
378              asMod = showModName (is_as spec)
379              origMod = showModName (is_mod spec)
380          return (unqual,QualCompls qual)
381
382      toCompItem :: Parent -> Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem]
383      toCompItem par m mn n imp' = do
384        docs <- getDocumentationTryGhc packageState curMod n
385        let (mbParent, originName) = case par of
386                            NoParent -> (Nothing, nameOccName n)
387                            ParentIs n' -> (Just . T.pack $ printName n', nameOccName n)
388                            FldParent n' lbl -> (Just . T.pack $ printName n', maybe (nameOccName n) mkVarOccFS lbl)
389        tys <- catchSrcErrors (hsc_dflags packageState) "completion" $ do
390                name' <- lookupName packageState m n
391                return ( name' >>= safeTyThingType
392                       , guard (isJust mbParent) >> name' >>= safeTyThingForRecord
393                       )
394        let (ty, record_ty) = fromRight (Nothing, Nothing) tys
395
396        let recordCompls = case record_ty of
397                Just (ctxStr, flds) | not (null flds) ->
398                    [mkRecordSnippetCompItem uri mbParent ctxStr flds (ppr mn) docs imp']
399                _ -> []
400
401        return $ mkNameCompItem uri mbParent originName mn ty Nothing docs imp'
402               : recordCompls
403
404  (unquals,quals) <- getCompls rdrElts
405
406  -- The list of all importable Modules from all packages
407  moduleNames <- maybe [] (map showModName) <$> envVisibleModuleNames env
408
409  return $ CC
410    { allModNamesAsNS = allModNamesAsNS
411    , unqualCompls = unquals
412    , qualCompls = quals
413    , anyQualCompls = []
414    , importableModules = moduleNames
415    }
416
417-- | Produces completions from the top level declarations of a module.
418localCompletionsForParsedModule :: Uri -> ParsedModule -> CachedCompletions
419localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} =
420    CC { allModNamesAsNS = mempty
421       , unqualCompls = compls
422       , qualCompls = mempty
423       , anyQualCompls = []
424       , importableModules = mempty
425        }
426  where
427    typeSigIds = Set.fromList
428        [ id
429            | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls
430            , L _ id <- ids
431            ]
432    hasTypeSig = (`Set.member` typeSigIds) . unLoc
433
434    compls = concat
435        [ case decl of
436            SigD _ (TypeSig _ ids typ) ->
437                [mkComp id CiFunction (Just $ ppr typ) | id <- ids]
438            ValD _ FunBind{fun_id} ->
439                [ mkComp fun_id CiFunction Nothing
440                | not (hasTypeSig fun_id)
441                ]
442            ValD _ PatBind{pat_lhs} ->
443                [mkComp id CiVariable Nothing
444                | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs]
445            TyClD _ ClassDecl{tcdLName, tcdSigs} ->
446                mkComp tcdLName CiInterface Nothing :
447                [ mkComp id CiFunction (Just $ ppr typ)
448                | L _ (ClassOpSig _ _ ids typ) <- tcdSigs
449                , id <- ids]
450            TyClD _ x ->
451                let generalCompls = [mkComp id cl Nothing
452                        | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x
453                        , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)]
454                    -- here we only have to look at the outermost type
455                    recordCompls = findRecordCompl uri pm thisModName x
456                in
457                   -- the constructors and snippets will be duplicated here giving the user 2 choices.
458                   generalCompls ++ recordCompls
459            ForD _ ForeignImport{fd_name,fd_sig_ty} ->
460                [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)]
461            ForD _ ForeignExport{fd_name,fd_sig_ty} ->
462                [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)]
463            _ -> []
464            | L _ decl <- hsmodDecls
465        ]
466
467    mkComp n ctyp ty =
468        CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiInterface]) Nothing
469      where
470        pn = ppr n
471        doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing)
472
473    thisModName = ppr hsmodName
474
475findRecordCompl :: Uri -> ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem]
476findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result
477    where
478        result = [mkRecordSnippetCompItem uri (Just $ showNameWithoutUniques $ unLoc tcdLName)
479                        (showGhc . unLoc $ con_name) field_labels mn doc Nothing
480                 | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn
481                 , Just  con_details <- [getFlds con_args]
482                 , let field_names = mapMaybe extract con_details
483                 , let field_labels = showGhc . unLoc <$> field_names
484                 , (not . List.null) field_labels
485                 ]
486        doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing)
487
488        getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs]
489        getFlds conArg = case conArg of
490                             RecCon rec  -> Just $ unLoc <$> unLoc rec
491                             PrefixCon _ -> Just []
492                             _           -> Nothing
493
494        extract ConDeclField{..}
495             -- TODO: Why is cd_fld_names a list?
496            | Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name
497            | otherwise = Nothing
498        -- XConDeclField
499        extract _ = Nothing
500findRecordCompl _ _ _ _ = []
501
502ppr :: Outputable a => a -> T.Text
503ppr = T.pack . prettyPrint
504
505toggleSnippets :: ClientCapabilities -> CompletionsConfig -> CompletionItem -> CompletionItem
506toggleSnippets ClientCapabilities {_textDocument} (CompletionsConfig with _) =
507  removeSnippetsWhen (not $ with && supported)
508  where
509    supported =
510      Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
511
512toggleAutoExtend :: CompletionsConfig -> CompItem -> CompItem
513toggleAutoExtend (CompletionsConfig _ False) x = x {additionalTextEdits = Nothing}
514toggleAutoExtend _ x = x
515
516removeSnippetsWhen :: Bool -> CompletionItem -> CompletionItem
517removeSnippetsWhen condition x =
518  if condition
519    then
520      x
521        { _insertTextFormat = Just PlainText,
522          _insertText = Nothing
523        }
524    else x
525
526-- | Returns the cached completions for the given module and position.
527getCompletions
528    :: PluginId
529    -> IdeOptions
530    -> CachedCompletions
531    -> Maybe (ParsedModule, PositionMapping)
532    -> (Bindings, PositionMapping)
533    -> VFS.PosPrefixInfo
534    -> ClientCapabilities
535    -> CompletionsConfig
536    -> HM.HashMap T.Text (HashSet.HashSet IdentInfo)
537    -> IO [CompletionItem]
538getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}
539               maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do
540  let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo
541      enteredQual = if T.null prefixModule then "" else prefixModule <> "."
542      fullPrefix  = enteredQual <> prefixText
543
544      {- correct the position by moving 'foo :: Int -> String ->    '
545                                                                    ^
546          to                             'foo :: Int -> String ->    '
547                                                              ^
548      -}
549      pos = VFS.cursorPos prefixInfo
550
551      filtModNameCompls =
552        map mkModCompl
553          $ mapMaybe (T.stripPrefix enteredQual)
554          $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS
555
556      filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False
557        where
558
559          mcc = case maybe_parsed of
560            Nothing -> Nothing
561            Just (pm, pmapping) ->
562              let PositionMapping pDelta = pmapping
563                  position' = fromDelta pDelta pos
564                  lpos = lowerRange position'
565                  hpos = upperRange position'
566              in getCContext lpos pm <|> getCContext hpos pm
567
568          -- completions specific to the current context
569          ctxCompls' = case mcc of
570                        Nothing           -> compls
571                        Just TypeContext  -> filter isTypeCompl compls
572                        Just ValueContext -> filter (not . isTypeCompl) compls
573                        Just _            -> filter (not . isTypeCompl) compls
574          -- Add whether the text to insert has backticks
575          ctxCompls = map (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls'
576
577          infixCompls :: Maybe Backtick
578          infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos
579
580          PositionMapping bDelta = bmapping
581          oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo
582          startLoc = lowerRange oldPos
583          endLoc = upperRange oldPos
584          localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc
585          localBindsToCompItem :: Name -> Maybe Type -> CompItem
586          localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing
587            where
588              occ = nameOccName name
589              ctyp = occNameToComKind Nothing occ
590              pn = ppr name
591              ty = ppr <$> typ
592              thisModName = case nameModule_maybe name of
593                Nothing -> Left $ nameSrcSpan name
594                Just m  -> Right $ ppr m
595
596          compls = if T.null prefixModule
597            then localCompls ++ unqualCompls ++ (($Nothing) <$> anyQualCompls)
598            else Map.findWithDefault [] prefixModule (getQualCompls qualCompls)
599                 ++ (($ Just prefixModule) <$> anyQualCompls)
600
601      filtListWith f list =
602        [ f label
603        | label <- Fuzzy.simpleFilter fullPrefix list
604        , enteredQual `T.isPrefixOf` label
605        ]
606
607      filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
608      filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName
609      filtKeywordCompls
610          | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
611          | otherwise = []
612
613  if
614    -- TODO: handle multiline imports
615    | "import " `T.isPrefixOf` fullLine
616      && (List.length (words (T.unpack fullLine)) >= 2)
617      && "(" `isInfixOf` T.unpack fullLine
618    -> do
619      let moduleName = T.pack $ words (T.unpack fullLine) !! 1
620          funcs = HM.lookupDefault HashSet.empty moduleName moduleExportsMap
621          funs = map (show . name) $ HashSet.toList funcs
622      return $ filterModuleExports moduleName $ map T.pack funs
623    | "import " `T.isPrefixOf` fullLine
624    -> return filtImportCompls
625    -- we leave this condition here to avoid duplications and return empty list
626    -- since HLS implements these completions (#haskell-language-server/pull/662)
627    | "{-# " `T.isPrefixOf` fullLine
628    -> return []
629    | otherwise -> do
630        -- assumes that nubOrdBy is stable
631        let uniqueFiltCompls = nubOrdBy uniqueCompl filtCompls
632        compls <- mapM (mkCompl plId ideOpts) uniqueFiltCompls
633        return $ filtModNameCompls
634              ++ filtKeywordCompls
635              ++ map (toggleSnippets caps config) compls
636
637uniqueCompl :: CompItem -> CompItem -> Ordering
638uniqueCompl x y =
639  case compare (label x, importedFrom x, compKind x)
640               (label y, importedFrom y, compKind y) of
641    EQ ->
642      -- preserve completions for duplicate record fields where the only difference is in the type
643      -- remove redundant completions with less type info
644      if typeText x == typeText y
645        || isNothing (typeText x)
646        || isNothing (typeText y)
647        then EQ
648        else compare (insertText x) (insertText y)
649    other -> other
650
651-- ---------------------------------------------------------------------
652-- helper functions for infix backticks
653-- ---------------------------------------------------------------------
654
655hasTrailingBacktick :: T.Text -> Position -> Bool
656hasTrailingBacktick line Position { _character }
657    | T.length line > _character = (line `T.index` _character) == '`'
658    | otherwise = False
659
660isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick
661isUsedAsInfix line prefixMod prefixText pos
662    | hasClosingBacktick && hasOpeningBacktick = Just Surrounded
663    | hasOpeningBacktick = Just LeftSide
664    | otherwise = Nothing
665  where
666    hasOpeningBacktick = openingBacktick line prefixMod prefixText pos
667    hasClosingBacktick = hasTrailingBacktick line pos
668
669openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool
670openingBacktick line prefixModule prefixText Position { _character }
671  | backtickIndex < 0 || backtickIndex > T.length line = False
672  | otherwise = (line `T.index` backtickIndex) == '`'
673    where
674    backtickIndex :: Int
675    backtickIndex =
676      let
677          prefixLength = T.length prefixText
678          moduleLength = if prefixModule == ""
679                    then 0
680                    else T.length prefixModule + 1 {- Because of "." -}
681      in
682        -- Points to the first letter of either the module or prefix text
683        _character - (prefixLength + moduleLength) - 1
684
685
686-- ---------------------------------------------------------------------
687
688-- | Under certain circumstance GHC generates some extra stuff that we
689-- don't want in the autocompleted symbols
690    {- When e.g. DuplicateRecordFields is enabled, compiler generates
691    names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors
692    https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
693    -}
694-- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.
695stripPrefix :: T.Text -> T.Text
696stripPrefix name = T.takeWhile (/=':') $ go prefixes
697  where
698    go [] = name
699    go (p:ps)
700      | T.isPrefixOf p name = T.drop (T.length p) name
701      | otherwise = go ps
702
703-- | Prefixes that can occur in a GHC OccName
704prefixes :: [T.Text]
705prefixes =
706  [
707    -- long ones
708    "$con2tag_"
709  , "$tag2con_"
710  , "$maxtag_"
711
712  -- four chars
713  , "$sel:"
714  , "$tc'"
715
716  -- three chars
717  , "$dm"
718  , "$co"
719  , "$tc"
720  , "$cp"
721  , "$fx"
722
723  -- two chars
724  , "$W"
725  , "$w"
726  , "$m"
727  , "$b"
728  , "$c"
729  , "$d"
730  , "$i"
731  , "$s"
732  , "$f"
733  , "$r"
734  , "C:"
735  , "N:"
736  , "D:"
737  , "$p"
738  , "$L"
739  , "$f"
740  , "$t"
741  , "$c"
742  , "$m"
743  ]
744
745
746safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text])
747safeTyThingForRecord (AnId _) = Nothing
748safeTyThingForRecord (AConLike dc) =
749    let ctxStr =   showGhc . occName . conLikeName $ dc
750        field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc
751    in
752        Just (ctxStr, field_names)
753safeTyThingForRecord _ = Nothing
754
755mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
756mkRecordSnippetCompItem uri parent ctxStr compl mn docs imp = r
757  where
758      r  = CI {
759            compKind = CiSnippet
760          , insertText = buildSnippet
761          , importedFrom = importedFrom
762          , typeText = Nothing
763          , label = ctxStr
764          , isInfix = Nothing
765          , docs = docs
766          , isTypeCompl = False
767          , additionalTextEdits = imp <&> \x ->
768            ExtendImport
769                { doc = uri,
770                  thingParent = parent,
771                  importName = showModName $ unLoc $ ideclName $ unLoc x,
772                  importQual = getImportQual x,
773                  newThing = ctxStr
774                }
775          }
776
777      placeholder_pairs = zip compl ([1..]::[Int])
778      snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs
779      snippet = T.intercalate (T.pack ", ") snippet_parts
780      buildSnippet = ctxStr <> " {" <> snippet <> "}"
781      importedFrom = Right mn
782
783getImportQual :: LImportDecl GhcPs -> Maybe T.Text
784getImportQual (L _ imp)
785    | isQualifiedImport imp = Just $ T.pack $ moduleNameString $ maybe (unLoc $ ideclName imp) unLoc (ideclAs imp)
786    | otherwise = Nothing
787