From 9222d1278b59e314c635f4df1cba8123a983362a Mon Sep 17 00:00:00 2001 From: grdvnl Date: Sat, 2 Jan 2021 05:10:09 -0800 Subject: [PATCH 1/7] Initial setup up completions as a HLS plugin --- exe/Plugins.hs | 4 +- ghcide/ghcide.cabal | 1 + .../IDE/Plugin/HLS/LocalCompletions.hs | 733 ++++++++++++++++++ 3 files changed, 737 insertions(+), 1 deletion(-) create mode 100644 ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 1bd2336e9c..fa5b50f15c 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -10,6 +10,7 @@ import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 import Development.IDE (IdeState) import Development.IDE.Plugin.HLS.GhcIde as GhcIde +import Development.IDE.Plugin.HLS.LocalCompletions as LocalCompletions -- haskell-language-server optional plugins @@ -81,7 +82,8 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins then basePlugins ++ examplePlugins else basePlugins basePlugins = - [ GhcIde.descriptor "ghcide" + [ GhcIde.descriptor "ghcide", + LocalCompletions.descriptor "localCompletions" #if pragmas , Pragmas.descriptor "pragmas" #endif diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index ec1d42774a..ed82bcdd57 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -166,6 +166,7 @@ library Development.IDE.Plugin.CodeAction Development.IDE.Plugin.HLS Development.IDE.Plugin.HLS.GhcIde + Development.IDE.Plugin.HLS.LocalCompletions Development.IDE.Plugin.Test -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses diff --git a/ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs b/ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs new file mode 100644 index 0000000000..b23685defc --- /dev/null +++ b/ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs @@ -0,0 +1,733 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + + +-- | Exposes the ghcide features as an HLS plugin +module Development.IDE.Plugin.HLS.LocalCompletions + ( + descriptor + ) where + +-- import Data.Aeson +-- import Development.IDE +-- import Development.IDE.Plugin as Ghcide +-- import Development.IDE.Plugin.Completions as Completions +-- import Development.IDE.LSP.Outline +-- import Ide.PluginUtils +-- import Ide.Types +-- import Language.Haskell.LSP.Types +-- import Text.Regex.TDFA.Text() + + +import Control.DeepSeq ( NFData ) +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Binary +import Data.Functor +import Data.Hashable +import qualified Data.Text as T +import Data.Typeable +import Development.IDE as D +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat (ParsedModule(ParsedModule)) +import Development.IDE.Spans.Common +import Development.IDE.Spans.Documentation +import Development.IDE.Core.Rules (useE) +import Development.IDE.Core.Shake as S +import GHC.Generics +import GHC.Generics as GG +-- import Ide.Plugin +import Ide.Types +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +import Control.Applicative +import Data.Char (isAlphaNum, isUpper) +import Data.Generics as G +import Data.List.Extra as List hiding (stripPrefix) +import qualified Data.Map as Map + +import Data.Maybe (listToMaybe, fromMaybe, mapMaybe) +import qualified Data.Text as T +import qualified Text.Fuzzy as Fuzzy + +import HscTypes +import Name +import RdrName +import Type +import Packages +-- #if MIN_GHC_API_VERSION(8,10,0) +-- import Predicate (isDictTy) +-- import Pair +-- import Coercion +-- #endif + +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Capabilities +-- import qualified Language.Haskell.LSP.VFS as VFS +-- import Development.IDE.Core.Compile +import Development.IDE.Core.PositionMapping +-- import Development.IDE.Plugin.Completions.Types +-- import Development.IDE.Spans.Documentation +import Development.IDE.Spans.LocalBindings +import Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Error +import Development.IDE.Types.Options +import Development.IDE.Spans.Common +import Development.IDE.GHC.Util +import Outputable (Outputable) +import qualified Data.Set as Set +import ConLike +import qualified Language.Haskell.LSP.Core as LSP +import qualified Language.Haskell.LSP.VFS as VFS + +import GhcPlugins ( + liftIO, + flLabel, + unpackFS) +import Control.DeepSeq + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { + pluginRules = produceLocalCompletions + , pluginCodeActionProvider = Nothing + , pluginCodeLensProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolsProvider = Nothing + , pluginCompletionProvider = Just getCompletionsLSP + } + +-- -- --------------------------------------------------------------------- + +-- descriptor :: PluginId -> PluginDescriptor IdeState +-- descriptor plId = (defaultPluginDescriptor plId) +-- { pluginCommands = [] +-- , pluginCodeActionProvider = Nothing +-- , pluginCodeLensProvider = Nothing +-- , pluginHoverProvider = Nothing +-- , pluginSymbolsProvider = Nothing +-- , pluginCompletionProvider = Just getCompletionsLSP +-- , pluginRules = Ghcide.pluginRules Completions.plugin +-- } + + +------------------------ +--- Completion Types +------------------------ + +data Backtick = Surrounded | LeftSide + deriving (Eq, Ord, Show) + + +-- | Intermediate Result of Completions +data CachedCompletions = CC + { + unqualCompls :: [CompItem] -- ^ All Possible completion items + } deriving Show + +instance NFData CachedCompletions where + rnf = rwhnf + +instance Monoid CachedCompletions where + mempty = CC mempty + +instance Semigroup CachedCompletions where + CC a <> CC a' = + CC (a<>a') + + +data CompItem = CI + { compKind :: CompletionItemKind, + -- | Snippet for the completion + insertText :: T.Text, + -- | From where this item is imported from. + importedFrom :: Either SrcSpan T.Text, + -- | Available type information. + typeText :: Maybe T.Text, + -- | Label to display to the user. + label :: T.Text, + -- | Did the completion happen + -- in the context of an infix notation. + isInfix :: Maybe Backtick, + -- | Available documentation. + docs :: SpanDoc, + isTypeCompl :: Bool, + additionalTextEdits :: Maybe [TextEdit] + } + deriving (Eq, Show) + +-- --------------------------------------------------------------------- +-- Generating Local Completions via Rules +-- --------------------------------------------------------------------- + +produceLocalCompletions :: Rules () +produceLocalCompletions = do + define $ \LocalCompletions file -> do + pm <- useWithStale GetParsedModule file + case pm of + Just (pm, _) -> do + let cdata = localCompletionsForParsedModule pm + return ([], Just cdata) + _ -> return ([], Nothing) + +-- | Produce completions info for a file +type instance RuleResult LocalCompletions = CachedCompletions + +data LocalCompletions = LocalCompletions + deriving (Eq, Show, Typeable, GG.Generic) +instance Hashable LocalCompletions +instance NFData LocalCompletions +instance Binary LocalCompletions + +-- | Generate code actions. +getCompletionsLSP + :: LSP.LspFuncs cofd + -> IdeState + -> CompletionParams + -> IO (Either ResponseError CompletionResponseResult) +getCompletionsLSP lsp ide + CompletionParams{_textDocument=TextDocumentIdentifier uri + ,_position=position + ,_context=completionContext} = do + contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri + fmap Right $ case (contents, uriToFilePath' uri) of + (Just cnts, Just path) -> do + let npath = toNormalizedFilePath' path + (ideOpts, compls) <- runIdeAction "Completion" (shakeExtras ide) $ do + opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide + compls <- useWithStaleFast LocalCompletions npath + pm <- useWithStaleFast GetParsedModule npath + binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath + pure (opts, fmap (,pm,binds) compls ) + case compls of + Just ((cci', _), parsedMod, bindMap) -> do + pfix <- VFS.getCompletionPrefix position cnts + case (pfix, completionContext) of + (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) + -> return (Completions $ List []) + (Just pfix', _) -> do + let extras = shakeExtras ide + clientCaps = S.clientCapabilities extras + compls = getCompletions ideOpts cci' parsedMod bindMap pfix' clientCaps (WithSnippets True) + Completions . List <$> compls + _ -> return (Completions $ List []) + _ -> return (Completions $ List []) + _ -> return (Completions $ List []) + + +completion :: CompletionProvider IdeState +completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) + = pure $ Right $ Completions $ List [r] + where + r = CompletionItem label kind tags detail documentation deprecated preselect + sortText filterText insertText insertTextFormat + textEdit additionalTextEdits commitCharacters + command xd + label = "New Local Completions" + kind = Nothing + tags = List [] + detail = Nothing + documentation = Nothing + deprecated = Nothing + preselect = Nothing + sortText = Nothing + filterText = Nothing + insertText = Nothing + insertTextFormat = Nothing + textEdit = Nothing + additionalTextEdits = Nothing + commitCharacters = Nothing + command = Nothing + xd = Nothing + +-- --------------------------------------------------------------------- +-- Supporting code +------------------------------------------------------------------------ + +-- | Produces completions from the top level declarations of a module. +localCompletionsForParsedModule :: ParsedModule -> CachedCompletions +localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} = + CC { unqualCompls = compls } + where + typeSigIds = Set.fromList + [ id + | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls + , L _ id <- ids + ] + hasTypeSig = (`Set.member` typeSigIds) . unLoc + + compls = concat + [ case decl of + SigD _ (TypeSig _ ids typ) -> + [mkComp id CiFunction (Just $ ppr typ) | id <- ids] + ValD _ FunBind{fun_id} -> + [ mkComp fun_id CiFunction Nothing + | not (hasTypeSig fun_id) + ] + ValD _ PatBind{pat_lhs} -> + [mkComp id CiVariable Nothing + | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] + TyClD _ ClassDecl{tcdLName, tcdSigs} -> + mkComp tcdLName CiClass Nothing : + [ mkComp id CiFunction (Just $ ppr typ) + | L _ (TypeSig _ ids typ) <- tcdSigs + , id <- ids] + TyClD _ x -> + let generalCompls = [mkComp id cl Nothing + | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x + , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)] + -- here we only have to look at the outermost type + recordCompls = findRecordCompl pm thisModName x + in + -- the constructors and snippets will be duplicated here giving the user 2 choices. + generalCompls ++ recordCompls + ForD _ ForeignImport{fd_name,fd_sig_ty} -> + [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + ForD _ ForeignExport{fd_name,fd_sig_ty} -> + [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + _ -> [] + | L _ decl <- hsmodDecls + ] + + mkComp n ctyp ty = + CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass]) Nothing + where + pn = ppr n + doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing) + + thisModName = ppr hsmodName + +findRecordCompl :: ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem] +findRecordCompl pmod mn DataDecl {tcdLName, tcdDataDefn} = result + where + result = [mkRecordSnippetCompItem (T.pack . showGhc . unLoc $ con_name) field_labels mn doc Nothing + | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn + , Just con_details <- [getFlds con_args] + , let field_names = mapMaybe extract con_details + , let field_labels = T.pack . showGhc . unLoc <$> field_names + , (not . List.null) field_labels + ] + doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing) + + getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs] + getFlds conArg = case conArg of + RecCon rec -> Just $ unLoc <$> unLoc rec + PrefixCon _ -> Just [] + _ -> Nothing + + extract ConDeclField{..} + -- TODO: Why is cd_fld_names a list? + | Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name + | otherwise = Nothing + -- XConDeclField + extract _ = Nothing +findRecordCompl _ _ _ = [] + + +ppr :: Outputable a => a -> T.Text +ppr = T.pack . prettyPrint + +occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind +occNameToComKind ty oc + | isVarOcc oc = case occNameString oc of + i:_ | isUpper i -> CiConstructor + _ -> CiFunction + | isTcOcc oc = case ty of + Just t + | "Constraint" `T.isSuffixOf` t + -> CiClass + _ -> CiStruct + | isDataOcc oc = CiConstructor + | otherwise = CiVariable + + +mkRecordSnippetCompItem :: T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem +mkRecordSnippetCompItem ctxStr compl mn docs imp = r + where + r = + CI + { compKind = CiSnippet, + insertText = buildSnippet, + importedFrom = importedFrom, + typeText = Nothing, + label = ctxStr, + isInfix = Nothing, + docs = docs, + isTypeCompl = False, + additionalTextEdits = imp >>= extendImportList (T.unpack ctxStr) + } + + placeholder_pairs = zip compl ([1 ..] :: [Int]) + snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs + snippet = T.intercalate (T.pack ", ") snippet_parts + buildSnippet = ctxStr <> " {" <> snippet <> "}" + importedFrom = Right mn + + +extendImportList :: String -> LImportDecl GhcPs -> Maybe [TextEdit] +extendImportList name lDecl = let + f (Just range) ImportDecl {ideclHiding} = case ideclHiding of + Just (False, x) + | Set.notMember name (Set.fromList [show y| y <- unLoc x]) + -> let + start_pos = _end range + new_start_pos = start_pos {_character = _character start_pos - 1} + -- use to same start_pos to handle situation where we do not have latest edits due to caching of Rules + new_range = Range new_start_pos new_start_pos + -- we cannot wrap mapM_ inside (mapM_) but we need to wrap (<$) + alpha = all isAlphaNum $ filter (\c -> c /= '_') name + result = if alpha then name ++ ", " + else "(" ++ name ++ "), " + in Just [TextEdit new_range (T.pack result)] + | otherwise -> Nothing + _ -> Nothing -- hiding import list and no list + f _ _ = Nothing + src_span = srcSpanToRange . getLoc $ lDecl + in f src_span . unLoc $ lDecl + + +--- Completions that are returned and related functions + +-- | 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 +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 r modName) <- moduleHeader + , pos `isInsideSrcSpan` r + = Just (ModuleContext (moduleNameString modName)) + + | Just (L r _) <- exportList + , pos `isInsideSrcSpan` 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 r SigD {}) + | pos `isInsideSrcSpan` r = Just TypeContext + | otherwise = Nothing + go (L r GHC.ValD {}) + | pos `isInsideSrcSpan` r = Just ValueContext + | otherwise = Nothing + go _ = Nothing + + goInline :: GHC.LHsType GhcPs -> Maybe Context + goInline (GHC.L r _) + | pos `isInsideSrcSpan` r = Just TypeContext + goInline _ = Nothing + + importGo :: GHC.LImportDecl GhcPs -> Maybe Context + importGo (L r impDecl) + | pos `isInsideSrcSpan` r + = importInline importModuleName (ideclHiding impDecl) + <|> Just (ImportContext importModuleName) + + | otherwise = Nothing + where importModuleName = moduleNameString $ unLoc $ ideclName impDecl + + importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context + importInline modName (Just (True, L r _)) + | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName + | otherwise = Nothing + importInline modName (Just (False, L r _)) + | pos `isInsideSrcSpan` r = Just $ ImportListContext modName + | otherwise = Nothing + importInline _ _ = Nothing + + +-- | Returns the cached completions for the given module and position. +getCompletions + :: IdeOptions + -> CachedCompletions + -> Maybe (ParsedModule, PositionMapping) + -> (Bindings, PositionMapping) + -> VFS.PosPrefixInfo + -> ClientCapabilities + -> WithSnippets + -> IO [CompletionItem] +getCompletions ideOpts CC { unqualCompls } + maybe_parsed (localBindings, bmapping) prefixInfo caps withSnippets = do + let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo + enteredQual = if T.null prefixModule then "" else prefixModule <> "." + fullPrefix = enteredQual <> prefixText + + {- correct the position by moving 'foo :: Int -> String -> ' + ^ + to 'foo :: Int -> String -> ' + ^ + -} + pos = VFS.cursorPos prefixInfo + + filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False + where + + mcc = case maybe_parsed of + Nothing -> Nothing + Just (pm, pmapping) -> + let PositionMapping pDelta = pmapping + position' = fromDelta pDelta pos + lpos = lowerRange position' + hpos = upperRange position' + in getCContext lpos pm <|> getCContext hpos pm + + -- completions specific to the current context + ctxCompls' = case mcc of + Nothing -> compls + Just TypeContext -> filter isTypeCompl compls + Just ValueContext -> filter (not . isTypeCompl) compls + Just _ -> 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 pos + + PositionMapping bDelta = bmapping + oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo + startLoc = lowerRange oldPos + endLoc = upperRange oldPos + localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc + localBindsToCompItem :: Name -> Maybe Type -> CompItem + localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing + where + occ = nameOccName name + ctyp = occNameToComKind Nothing occ + pn = ppr name + ty = ppr <$> typ + thisModName = case nameModule_maybe name of + Nothing -> Left $ nameSrcSpan name + Just m -> Right $ ppr m + + compls = if T.null prefixModule + then localCompls ++ unqualCompls + else [] + + 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:: T.Text))) + | (snippet, label) <- list + , Fuzzy.test fullPrefix label + ] + + filtKeywordCompls + | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts) + | otherwise = [] + + stripLeading :: Char -> String -> String + stripLeading _ [] = [] + stripLeading c (s:ss) + | s == c = ss + | otherwise = s:ss + + result + | "import " `T.isPrefixOf` fullLine + = [] + | "{-#" `T.isPrefixOf` T.toLower fullLine + = [] + | otherwise + = let uniqueFiltCompls = nubOrdOn insertText filtCompls + in map (toggleSnippets caps withSnippets + . mkCompl ideOpts . stripAutoGenerated) uniqueFiltCompls + ++ filtKeywordCompls + return result + + +mkCompl :: IdeOptions -> CompItem -> CompletionItem +mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs, additionalTextEdits} = + CompletionItem {_label = label, + _kind = kind, + _tags = List [], + _detail = (colon <>) <$> typeText, + _documentation = documentation, + _deprecated = Nothing, + _preselect = Nothing, + _sortText = Nothing, + _filterText = Nothing, + _insertText = Just insertText, + _insertTextFormat = Just Snippet, + _textEdit = Nothing, + _additionalTextEdits = List <$> additionalTextEdits, + _commitCharacters = Nothing, + _command = Nothing, + _xdata = Nothing} + + where kind = Just compKind + docs' = imported : spanDocToMarkdown docs + imported = case importedFrom of + Left pos -> "*Defined at '" <> ppr pos <> "'*\n'" + Right mod -> "*Defined in '" <> mod <> "'*\n" + colon = if optNewColonConvention then ": " else ":: " + documentation = Just $ CompletionDocMarkup $ + MarkupContent MkMarkdown $ + T.intercalate sectionSeparator docs' + +-- TODO: We probably don't need to this function in this module +mkExtCompl :: T.Text -> CompletionItem +mkExtCompl label = + CompletionItem + label + (Just CiKeyword) + (List []) + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + + +--- helper functions that will be useful for non-local completions as well + +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 + +toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem +toggleSnippets ClientCapabilities {_textDocument} (WithSnippets with) x + | with && supported = x + | otherwise = + x + { _insertTextFormat = Just PlainText, + _insertText = Nothing + } + where + supported = + Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) + +-- | 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 + -} + +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" + ] From 3cd336d834db58d619a31705364a202758caac3e Mon Sep 17 00:00:00 2001 From: grdvnl Date: Sat, 2 Jan 2021 05:39:50 -0800 Subject: [PATCH 2/7] Update comment --- ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs b/ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs index b23685defc..ddb132fd2a 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs @@ -195,7 +195,7 @@ instance Hashable LocalCompletions instance NFData LocalCompletions instance Binary LocalCompletions --- | Generate code actions. +-- | Generate Completions. getCompletionsLSP :: LSP.LspFuncs cofd -> IdeState From 8b97ae5245d20a712bc42c9990aeeeddda5fe9e1 Mon Sep 17 00:00:00 2001 From: grdvnl Date: Sat, 2 Jan 2021 05:40:01 -0800 Subject: [PATCH 3/7] Disable local completions from old module --- ghcide/src/Development/IDE/Plugin/Completions/Logic.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 2d91e297ff..7291ebce4f 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -524,7 +524,7 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl Just m -> Right $ ppr m compls = if T.null prefixModule - then localCompls ++ unqualCompls + then [] else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls filtListWith f list = From 32e34be587eca3e07a5bcc4085dc1b102026978c Mon Sep 17 00:00:00 2001 From: grdvnl Date: Sat, 2 Jan 2021 06:01:20 -0800 Subject: [PATCH 4/7] Remove local completions from old module --- .../src/Development/IDE/Plugin/Completions.hs | 17 +---------------- 1 file changed, 1 insertion(+), 16 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 4c3ad93f41..4926997c94 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -41,17 +41,9 @@ plugin = Plugin produceCompletions setHandlersCompletion produceCompletions :: Rules () produceCompletions = do define $ \ProduceCompletions file -> do - local <- useWithStale LocalCompletions file nonLocal <- useWithStale NonLocalCompletions file let extract = fmap fst - return ([], extract local <> extract nonLocal) - define $ \LocalCompletions file -> do - pm <- useWithStale GetParsedModule file - case pm of - Just (pm, _) -> do - let cdata = localCompletionsForParsedModule pm - return ([], Just cdata) - _ -> return ([], Nothing) + return ([], extract nonLocal) define $ \NonLocalCompletions file -> do -- For non local completions we avoid depending on the parsed module, -- synthetizing a fake module with an empty body from the buffer @@ -93,7 +85,6 @@ dropListFromImportDecl iDecl = let -- | Produce completions info for a file type instance RuleResult ProduceCompletions = CachedCompletions -type instance RuleResult LocalCompletions = CachedCompletions type instance RuleResult NonLocalCompletions = CachedCompletions data ProduceCompletions = ProduceCompletions @@ -102,12 +93,6 @@ instance Hashable ProduceCompletions instance NFData ProduceCompletions instance Binary ProduceCompletions -data LocalCompletions = LocalCompletions - deriving (Eq, Show, Typeable, Generic) -instance Hashable LocalCompletions -instance NFData LocalCompletions -instance Binary LocalCompletions - data NonLocalCompletions = NonLocalCompletions deriving (Eq, Show, Typeable, Generic) instance Hashable NonLocalCompletions From 9ac7054262ebca8ae82ab0c507dd39cee02cc3bd Mon Sep 17 00:00:00 2001 From: grdvnl Date: Sat, 2 Jan 2021 07:13:52 -0800 Subject: [PATCH 5/7] Revert using separate module, but move Completions as plugin --- exe/Plugins.hs | 4 +-- ghcide/ghcide.cabal | 2 +- .../IDE/Plugin/Completions/Logic.hs | 2 +- .../Development/IDE/Plugin/HLS/Completions.hs | 30 +++++++++++++++++++ 4 files changed, 34 insertions(+), 4 deletions(-) create mode 100644 ghcide/src/Development/IDE/Plugin/HLS/Completions.hs diff --git a/exe/Plugins.hs b/exe/Plugins.hs index fa5b50f15c..69d98d0866 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -10,7 +10,7 @@ import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 import Development.IDE (IdeState) import Development.IDE.Plugin.HLS.GhcIde as GhcIde -import Development.IDE.Plugin.HLS.LocalCompletions as LocalCompletions +import Development.IDE.Plugin.HLS.Completions as Completions -- haskell-language-server optional plugins @@ -83,7 +83,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins else basePlugins basePlugins = [ GhcIde.descriptor "ghcide", - LocalCompletions.descriptor "localCompletions" + Completions.descriptor "completions" #if pragmas , Pragmas.descriptor "pragmas" #endif diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index ed82bcdd57..046898b67c 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -166,7 +166,7 @@ library Development.IDE.Plugin.CodeAction Development.IDE.Plugin.HLS Development.IDE.Plugin.HLS.GhcIde - Development.IDE.Plugin.HLS.LocalCompletions + Development.IDE.Plugin.HLS.Completions Development.IDE.Plugin.Test -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 7291ebce4f..2d91e297ff 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -524,7 +524,7 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl Just m -> Right $ ppr m compls = if T.null prefixModule - then [] + then localCompls ++ unqualCompls else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls filtListWith f list = diff --git a/ghcide/src/Development/IDE/Plugin/HLS/Completions.hs b/ghcide/src/Development/IDE/Plugin/HLS/Completions.hs new file mode 100644 index 0000000000..80df40432f --- /dev/null +++ b/ghcide/src/Development/IDE/Plugin/HLS/Completions.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Exposes the ghcide features as an HLS plugin +module Development.IDE.Plugin.HLS.Completions + ( + descriptor + ) where + +import Data.Aeson +import Development.IDE +import Development.IDE.Plugin as Ghcide +import Development.IDE.Plugin.Completions as Completions +import Ide.PluginUtils +import Ide.Types +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) + { pluginCommands = [] + , pluginCodeActionProvider = Nothing + , pluginCodeLensProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolsProvider = Nothing + , pluginCompletionProvider = Just getCompletionsLSP + , pluginRules = Ghcide.pluginRules Completions.plugin + } From 32840a50ec289a21f4081bdd09a9f6bfef07db40 Mon Sep 17 00:00:00 2001 From: grdvnl Date: Sat, 2 Jan 2021 07:16:28 -0800 Subject: [PATCH 6/7] Remove LocalCompletions module --- .../IDE/Plugin/HLS/LocalCompletions.hs | 733 ------------------ 1 file changed, 733 deletions(-) delete mode 100644 ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs diff --git a/ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs b/ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs deleted file mode 100644 index ddb132fd2a..0000000000 --- a/ghcide/src/Development/IDE/Plugin/HLS/LocalCompletions.hs +++ /dev/null @@ -1,733 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} - - --- | Exposes the ghcide features as an HLS plugin -module Development.IDE.Plugin.HLS.LocalCompletions - ( - descriptor - ) where - --- import Data.Aeson --- import Development.IDE --- import Development.IDE.Plugin as Ghcide --- import Development.IDE.Plugin.Completions as Completions --- import Development.IDE.LSP.Outline --- import Ide.PluginUtils --- import Ide.Types --- import Language.Haskell.LSP.Types --- import Text.Regex.TDFA.Text() - - -import Control.DeepSeq ( NFData ) -import Control.Monad.Trans.Maybe -import Data.Aeson -import Data.Binary -import Data.Functor -import Data.Hashable -import qualified Data.Text as T -import Data.Typeable -import Development.IDE as D -import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat (ParsedModule(ParsedModule)) -import Development.IDE.Spans.Common -import Development.IDE.Spans.Documentation -import Development.IDE.Core.Rules (useE) -import Development.IDE.Core.Shake as S -import GHC.Generics -import GHC.Generics as GG --- import Ide.Plugin -import Ide.Types -import Language.Haskell.LSP.Types -import Text.Regex.TDFA.Text() - -import Control.Applicative -import Data.Char (isAlphaNum, isUpper) -import Data.Generics as G -import Data.List.Extra as List hiding (stripPrefix) -import qualified Data.Map as Map - -import Data.Maybe (listToMaybe, fromMaybe, mapMaybe) -import qualified Data.Text as T -import qualified Text.Fuzzy as Fuzzy - -import HscTypes -import Name -import RdrName -import Type -import Packages --- #if MIN_GHC_API_VERSION(8,10,0) --- import Predicate (isDictTy) --- import Pair --- import Coercion --- #endif - -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities --- import qualified Language.Haskell.LSP.VFS as VFS --- import Development.IDE.Core.Compile -import Development.IDE.Core.PositionMapping --- import Development.IDE.Plugin.Completions.Types --- import Development.IDE.Spans.Documentation -import Development.IDE.Spans.LocalBindings -import Development.IDE.GHC.Compat as GHC -import Development.IDE.GHC.Error -import Development.IDE.Types.Options -import Development.IDE.Spans.Common -import Development.IDE.GHC.Util -import Outputable (Outputable) -import qualified Data.Set as Set -import ConLike -import qualified Language.Haskell.LSP.Core as LSP -import qualified Language.Haskell.LSP.VFS as VFS - -import GhcPlugins ( - liftIO, - flLabel, - unpackFS) -import Control.DeepSeq - --- --------------------------------------------------------------------- - -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { - pluginRules = produceLocalCompletions - , pluginCodeActionProvider = Nothing - , pluginCodeLensProvider = Nothing - , pluginHoverProvider = Nothing - , pluginSymbolsProvider = Nothing - , pluginCompletionProvider = Just getCompletionsLSP - } - --- -- --------------------------------------------------------------------- - --- descriptor :: PluginId -> PluginDescriptor IdeState --- descriptor plId = (defaultPluginDescriptor plId) --- { pluginCommands = [] --- , pluginCodeActionProvider = Nothing --- , pluginCodeLensProvider = Nothing --- , pluginHoverProvider = Nothing --- , pluginSymbolsProvider = Nothing --- , pluginCompletionProvider = Just getCompletionsLSP --- , pluginRules = Ghcide.pluginRules Completions.plugin --- } - - ------------------------- ---- Completion Types ------------------------- - -data Backtick = Surrounded | LeftSide - deriving (Eq, Ord, Show) - - --- | Intermediate Result of Completions -data CachedCompletions = CC - { - unqualCompls :: [CompItem] -- ^ All Possible completion items - } deriving Show - -instance NFData CachedCompletions where - rnf = rwhnf - -instance Monoid CachedCompletions where - mempty = CC mempty - -instance Semigroup CachedCompletions where - CC a <> CC a' = - CC (a<>a') - - -data CompItem = CI - { compKind :: CompletionItemKind, - -- | Snippet for the completion - insertText :: T.Text, - -- | From where this item is imported from. - importedFrom :: Either SrcSpan T.Text, - -- | Available type information. - typeText :: Maybe T.Text, - -- | Label to display to the user. - label :: T.Text, - -- | Did the completion happen - -- in the context of an infix notation. - isInfix :: Maybe Backtick, - -- | Available documentation. - docs :: SpanDoc, - isTypeCompl :: Bool, - additionalTextEdits :: Maybe [TextEdit] - } - deriving (Eq, Show) - --- --------------------------------------------------------------------- --- Generating Local Completions via Rules --- --------------------------------------------------------------------- - -produceLocalCompletions :: Rules () -produceLocalCompletions = do - define $ \LocalCompletions file -> do - pm <- useWithStale GetParsedModule file - case pm of - Just (pm, _) -> do - let cdata = localCompletionsForParsedModule pm - return ([], Just cdata) - _ -> return ([], Nothing) - --- | Produce completions info for a file -type instance RuleResult LocalCompletions = CachedCompletions - -data LocalCompletions = LocalCompletions - deriving (Eq, Show, Typeable, GG.Generic) -instance Hashable LocalCompletions -instance NFData LocalCompletions -instance Binary LocalCompletions - --- | Generate Completions. -getCompletionsLSP - :: LSP.LspFuncs cofd - -> IdeState - -> CompletionParams - -> IO (Either ResponseError CompletionResponseResult) -getCompletionsLSP lsp ide - CompletionParams{_textDocument=TextDocumentIdentifier uri - ,_position=position - ,_context=completionContext} = do - contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri - fmap Right $ case (contents, uriToFilePath' uri) of - (Just cnts, Just path) -> do - let npath = toNormalizedFilePath' path - (ideOpts, compls) <- runIdeAction "Completion" (shakeExtras ide) $ do - opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide - compls <- useWithStaleFast LocalCompletions npath - pm <- useWithStaleFast GetParsedModule npath - binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath - pure (opts, fmap (,pm,binds) compls ) - case compls of - Just ((cci', _), parsedMod, bindMap) -> do - pfix <- VFS.getCompletionPrefix position cnts - case (pfix, completionContext) of - (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) - -> return (Completions $ List []) - (Just pfix', _) -> do - let extras = shakeExtras ide - clientCaps = S.clientCapabilities extras - compls = getCompletions ideOpts cci' parsedMod bindMap pfix' clientCaps (WithSnippets True) - Completions . List <$> compls - _ -> return (Completions $ List []) - _ -> return (Completions $ List []) - _ -> return (Completions $ List []) - - -completion :: CompletionProvider IdeState -completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) - = pure $ Right $ Completions $ List [r] - where - r = CompletionItem label kind tags detail documentation deprecated preselect - sortText filterText insertText insertTextFormat - textEdit additionalTextEdits commitCharacters - command xd - label = "New Local Completions" - kind = Nothing - tags = List [] - detail = Nothing - documentation = Nothing - deprecated = Nothing - preselect = Nothing - sortText = Nothing - filterText = Nothing - insertText = Nothing - insertTextFormat = Nothing - textEdit = Nothing - additionalTextEdits = Nothing - commitCharacters = Nothing - command = Nothing - xd = Nothing - --- --------------------------------------------------------------------- --- Supporting code ------------------------------------------------------------------------- - --- | Produces completions from the top level declarations of a module. -localCompletionsForParsedModule :: ParsedModule -> CachedCompletions -localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} = - CC { unqualCompls = compls } - where - typeSigIds = Set.fromList - [ id - | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls - , L _ id <- ids - ] - hasTypeSig = (`Set.member` typeSigIds) . unLoc - - compls = concat - [ case decl of - SigD _ (TypeSig _ ids typ) -> - [mkComp id CiFunction (Just $ ppr typ) | id <- ids] - ValD _ FunBind{fun_id} -> - [ mkComp fun_id CiFunction Nothing - | not (hasTypeSig fun_id) - ] - ValD _ PatBind{pat_lhs} -> - [mkComp id CiVariable Nothing - | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] - TyClD _ ClassDecl{tcdLName, tcdSigs} -> - mkComp tcdLName CiClass Nothing : - [ mkComp id CiFunction (Just $ ppr typ) - | L _ (TypeSig _ ids typ) <- tcdSigs - , id <- ids] - TyClD _ x -> - let generalCompls = [mkComp id cl Nothing - | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x - , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)] - -- here we only have to look at the outermost type - recordCompls = findRecordCompl pm thisModName x - in - -- the constructors and snippets will be duplicated here giving the user 2 choices. - generalCompls ++ recordCompls - ForD _ ForeignImport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] - ForD _ ForeignExport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] - _ -> [] - | L _ decl <- hsmodDecls - ] - - mkComp n ctyp ty = - CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass]) Nothing - where - pn = ppr n - doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing) - - thisModName = ppr hsmodName - -findRecordCompl :: ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem] -findRecordCompl pmod mn DataDecl {tcdLName, tcdDataDefn} = result - where - result = [mkRecordSnippetCompItem (T.pack . showGhc . unLoc $ con_name) field_labels mn doc Nothing - | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn - , Just con_details <- [getFlds con_args] - , let field_names = mapMaybe extract con_details - , let field_labels = T.pack . showGhc . unLoc <$> field_names - , (not . List.null) field_labels - ] - doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing) - - getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs] - getFlds conArg = case conArg of - RecCon rec -> Just $ unLoc <$> unLoc rec - PrefixCon _ -> Just [] - _ -> Nothing - - extract ConDeclField{..} - -- TODO: Why is cd_fld_names a list? - | Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name - | otherwise = Nothing - -- XConDeclField - extract _ = Nothing -findRecordCompl _ _ _ = [] - - -ppr :: Outputable a => a -> T.Text -ppr = T.pack . prettyPrint - -occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind -occNameToComKind ty oc - | isVarOcc oc = case occNameString oc of - i:_ | isUpper i -> CiConstructor - _ -> CiFunction - | isTcOcc oc = case ty of - Just t - | "Constraint" `T.isSuffixOf` t - -> CiClass - _ -> CiStruct - | isDataOcc oc = CiConstructor - | otherwise = CiVariable - - -mkRecordSnippetCompItem :: T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem -mkRecordSnippetCompItem ctxStr compl mn docs imp = r - where - r = - CI - { compKind = CiSnippet, - insertText = buildSnippet, - importedFrom = importedFrom, - typeText = Nothing, - label = ctxStr, - isInfix = Nothing, - docs = docs, - isTypeCompl = False, - additionalTextEdits = imp >>= extendImportList (T.unpack ctxStr) - } - - placeholder_pairs = zip compl ([1 ..] :: [Int]) - snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs - snippet = T.intercalate (T.pack ", ") snippet_parts - buildSnippet = ctxStr <> " {" <> snippet <> "}" - importedFrom = Right mn - - -extendImportList :: String -> LImportDecl GhcPs -> Maybe [TextEdit] -extendImportList name lDecl = let - f (Just range) ImportDecl {ideclHiding} = case ideclHiding of - Just (False, x) - | Set.notMember name (Set.fromList [show y| y <- unLoc x]) - -> let - start_pos = _end range - new_start_pos = start_pos {_character = _character start_pos - 1} - -- use to same start_pos to handle situation where we do not have latest edits due to caching of Rules - new_range = Range new_start_pos new_start_pos - -- we cannot wrap mapM_ inside (mapM_) but we need to wrap (<$) - alpha = all isAlphaNum $ filter (\c -> c /= '_') name - result = if alpha then name ++ ", " - else "(" ++ name ++ "), " - in Just [TextEdit new_range (T.pack result)] - | otherwise -> Nothing - _ -> Nothing -- hiding import list and no list - f _ _ = Nothing - src_span = srcSpanToRange . getLoc $ lDecl - in f src_span . unLoc $ lDecl - - ---- Completions that are returned and related functions - --- | 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 -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 r modName) <- moduleHeader - , pos `isInsideSrcSpan` r - = Just (ModuleContext (moduleNameString modName)) - - | Just (L r _) <- exportList - , pos `isInsideSrcSpan` 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 r SigD {}) - | pos `isInsideSrcSpan` r = Just TypeContext - | otherwise = Nothing - go (L r GHC.ValD {}) - | pos `isInsideSrcSpan` r = Just ValueContext - | otherwise = Nothing - go _ = Nothing - - goInline :: GHC.LHsType GhcPs -> Maybe Context - goInline (GHC.L r _) - | pos `isInsideSrcSpan` r = Just TypeContext - goInline _ = Nothing - - importGo :: GHC.LImportDecl GhcPs -> Maybe Context - importGo (L r impDecl) - | pos `isInsideSrcSpan` r - = importInline importModuleName (ideclHiding impDecl) - <|> Just (ImportContext importModuleName) - - | otherwise = Nothing - where importModuleName = moduleNameString $ unLoc $ ideclName impDecl - - importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context - importInline modName (Just (True, L r _)) - | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName - | otherwise = Nothing - importInline modName (Just (False, L r _)) - | pos `isInsideSrcSpan` r = Just $ ImportListContext modName - | otherwise = Nothing - importInline _ _ = Nothing - - --- | Returns the cached completions for the given module and position. -getCompletions - :: IdeOptions - -> CachedCompletions - -> Maybe (ParsedModule, PositionMapping) - -> (Bindings, PositionMapping) - -> VFS.PosPrefixInfo - -> ClientCapabilities - -> WithSnippets - -> IO [CompletionItem] -getCompletions ideOpts CC { unqualCompls } - maybe_parsed (localBindings, bmapping) prefixInfo caps withSnippets = do - let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo - enteredQual = if T.null prefixModule then "" else prefixModule <> "." - fullPrefix = enteredQual <> prefixText - - {- correct the position by moving 'foo :: Int -> String -> ' - ^ - to 'foo :: Int -> String -> ' - ^ - -} - pos = VFS.cursorPos prefixInfo - - filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False - where - - mcc = case maybe_parsed of - Nothing -> Nothing - Just (pm, pmapping) -> - let PositionMapping pDelta = pmapping - position' = fromDelta pDelta pos - lpos = lowerRange position' - hpos = upperRange position' - in getCContext lpos pm <|> getCContext hpos pm - - -- completions specific to the current context - ctxCompls' = case mcc of - Nothing -> compls - Just TypeContext -> filter isTypeCompl compls - Just ValueContext -> filter (not . isTypeCompl) compls - Just _ -> 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 pos - - PositionMapping bDelta = bmapping - oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo - startLoc = lowerRange oldPos - endLoc = upperRange oldPos - localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc - localBindsToCompItem :: Name -> Maybe Type -> CompItem - localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing - where - occ = nameOccName name - ctyp = occNameToComKind Nothing occ - pn = ppr name - ty = ppr <$> typ - thisModName = case nameModule_maybe name of - Nothing -> Left $ nameSrcSpan name - Just m -> Right $ ppr m - - compls = if T.null prefixModule - then localCompls ++ unqualCompls - else [] - - 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:: T.Text))) - | (snippet, label) <- list - , Fuzzy.test fullPrefix label - ] - - filtKeywordCompls - | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts) - | otherwise = [] - - stripLeading :: Char -> String -> String - stripLeading _ [] = [] - stripLeading c (s:ss) - | s == c = ss - | otherwise = s:ss - - result - | "import " `T.isPrefixOf` fullLine - = [] - | "{-#" `T.isPrefixOf` T.toLower fullLine - = [] - | otherwise - = let uniqueFiltCompls = nubOrdOn insertText filtCompls - in map (toggleSnippets caps withSnippets - . mkCompl ideOpts . stripAutoGenerated) uniqueFiltCompls - ++ filtKeywordCompls - return result - - -mkCompl :: IdeOptions -> CompItem -> CompletionItem -mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs, additionalTextEdits} = - CompletionItem {_label = label, - _kind = kind, - _tags = List [], - _detail = (colon <>) <$> typeText, - _documentation = documentation, - _deprecated = Nothing, - _preselect = Nothing, - _sortText = Nothing, - _filterText = Nothing, - _insertText = Just insertText, - _insertTextFormat = Just Snippet, - _textEdit = Nothing, - _additionalTextEdits = List <$> additionalTextEdits, - _commitCharacters = Nothing, - _command = Nothing, - _xdata = Nothing} - - where kind = Just compKind - docs' = imported : spanDocToMarkdown docs - imported = case importedFrom of - Left pos -> "*Defined at '" <> ppr pos <> "'*\n'" - Right mod -> "*Defined in '" <> mod <> "'*\n" - colon = if optNewColonConvention then ": " else ":: " - documentation = Just $ CompletionDocMarkup $ - MarkupContent MkMarkdown $ - T.intercalate sectionSeparator docs' - --- TODO: We probably don't need to this function in this module -mkExtCompl :: T.Text -> CompletionItem -mkExtCompl label = - CompletionItem - label - (Just CiKeyword) - (List []) - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - - ---- helper functions that will be useful for non-local completions as well - -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 - -toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem -toggleSnippets ClientCapabilities {_textDocument} (WithSnippets with) x - | with && supported = x - | otherwise = - x - { _insertTextFormat = Just PlainText, - _insertText = Nothing - } - where - supported = - Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) - --- | 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 - -} - -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" - ] From f1941e030bc5544d2aca2d796ce3667484aea60e Mon Sep 17 00:00:00 2001 From: grdvnl Date: Sat, 2 Jan 2021 07:24:50 -0800 Subject: [PATCH 7/7] Minimal re-org of completions. --- ghcide/exe/Main.hs | 3 ++- .../src/Development/IDE/Plugin/Completions.hs | 17 ++++++++++++++++- ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs | 4 ++-- 3 files changed, 20 insertions(+), 4 deletions(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 5a3adfd546..1837e9b847 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -54,6 +54,7 @@ import Development.IDE.Core.Tracing import Development.IDE.Types.Shake (Key(Key)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) import Development.IDE.Plugin.HLS.GhcIde as GhcIde +import Development.IDE.Plugin.HLS.Completions as Completions import Ide.Plugin.Config import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins) @@ -86,7 +87,7 @@ main = do dir <- IO.getCurrentDirectory - let hlsPlugins = pluginDescToIdePlugins [GhcIde.descriptor "ghcide"] + let hlsPlugins = pluginDescToIdePlugins [GhcIde.descriptor "ghcide", Completions.descriptor "completions"] pid <- T.pack . show <$> getProcessID let hlsPlugin = asGhcIdePlugin hlsPlugins diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 4926997c94..4c3ad93f41 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -41,9 +41,17 @@ plugin = Plugin produceCompletions setHandlersCompletion produceCompletions :: Rules () produceCompletions = do define $ \ProduceCompletions file -> do + local <- useWithStale LocalCompletions file nonLocal <- useWithStale NonLocalCompletions file let extract = fmap fst - return ([], extract nonLocal) + return ([], extract local <> extract nonLocal) + define $ \LocalCompletions file -> do + pm <- useWithStale GetParsedModule file + case pm of + Just (pm, _) -> do + let cdata = localCompletionsForParsedModule pm + return ([], Just cdata) + _ -> return ([], Nothing) define $ \NonLocalCompletions file -> do -- For non local completions we avoid depending on the parsed module, -- synthetizing a fake module with an empty body from the buffer @@ -85,6 +93,7 @@ dropListFromImportDecl iDecl = let -- | Produce completions info for a file type instance RuleResult ProduceCompletions = CachedCompletions +type instance RuleResult LocalCompletions = CachedCompletions type instance RuleResult NonLocalCompletions = CachedCompletions data ProduceCompletions = ProduceCompletions @@ -93,6 +102,12 @@ instance Hashable ProduceCompletions instance NFData ProduceCompletions instance Binary ProduceCompletions +data LocalCompletions = LocalCompletions + deriving (Eq, Show, Typeable, Generic) +instance Hashable LocalCompletions +instance NFData LocalCompletions +instance Binary LocalCompletions + data NonLocalCompletions = NonLocalCompletions deriving (Eq, Show, Typeable, Generic) instance Hashable NonLocalCompletions diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index dfcc6e72ed..5108ae5cfc 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -28,8 +28,8 @@ descriptor plId = (defaultPluginDescriptor plId) , pluginCodeLensProvider = Just codeLens' , pluginHoverProvider = Just hover' , pluginSymbolsProvider = Just symbolsProvider - , pluginCompletionProvider = Just getCompletionsLSP - , pluginRules = Ghcide.pluginRules Completions.plugin <> Ghcide.pluginRules CodeAction.plugin + , pluginCompletionProvider = Nothing + , pluginRules = Ghcide.pluginRules CodeAction.plugin } -- ---------------------------------------------------------------------