diff --git a/ghcide-test/exe/CompletionTests.hs b/ghcide-test/exe/CompletionTests.hs index 8c44173bd6..8fc64c6624 100644 --- a/ghcide-test/exe/CompletionTests.hs +++ b/ghcide-test/exe/CompletionTests.hs @@ -43,6 +43,7 @@ tests , testGroup "package" packageCompletionTests , testGroup "project" projectCompletionTests , testGroup "other" otherCompletionTests + , testGroup "context" contextCompletionTests , testGroup "doc" completionDocTests ] @@ -516,6 +517,183 @@ projectCompletionTests = item ^. L.label @?= "anidentifier" ] +contextCompletionTests :: [TestTree] +contextCompletionTests = + [ completionTest + "type context filters out value completions" + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + , "data Xxxtype = Xxxcon" + , "xxxval = ()" + , "g :: Xxx" + ] + (Position 4 8) + [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)] + + , completionTest + "type sig in where-clause gives type completions" + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + , "data Xxxtype = Xxxcon" + , "xxxval = ()" + , "foo x = bar" + , " where" + , " helper :: Xxx" + , " helper = bar" + ] + (Position 6 17) -- after "Xxx" in " helper :: Xxx" + [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)] + + , testSessionSingleFile "value binding in where-clause gives value completions" "A.hs" + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + -- the type shares the value's prefix, so only the context filter excludes it. + , "data Xxxvaltype = Xxxcon" + , "xxxval = ()" + , "foo x = bar" + , " where" + , " helper = xxxv" + ]) $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 6 16) -- after "xxxv" + let labels = map (^. L.label) compls + liftIO $ assertBool "xxxval should appear in value context" ("xxxval" `elem` labels) + liftIO $ assertBool "Xxxvaltype should not appear in value context" + (not ("Xxxvaltype" `elem` labels)) + + , completionTest + "type sig in nested where-clause gives type completions" + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + , "data Xxxtype = Xxxcon" + , "xxxval = ()" + , "foo x = outer" + , " where" + , " inner y = result" + , " where" + , " sig :: Xxx" + , " sig = undefined" + ] + (Position 8 18) + [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)] + + , completionTest + "type sig in match alternative where-clause gives type completions" + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + , "data Xxxtype = Xxxcon" + , "xxxval = ()" + , "foo 0 = bar" + , " where helper :: Xxx" + , "foo _ = baz" + ] + (Position 5 21) -- after "Xxx" in " where helper :: Xxx" + [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)] + + , completionTest + "type sig in pattern binding where-clause gives type completions" + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + , "data Xxxtype = Xxxcon" + , "xxxval = ()" + , "(a, b) = (undefined, undefined)" + , " where" + , " helper :: Xxx" + , " helper = undefined" + ] + (Position 6 17) -- after "Xxx" in " helper :: Xxx" + [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)] + + , completionTest + "type sig in let expression gives type completions" + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + , "data Xxxtype = Xxxcon" + , "xxxval = ()" + , "foo =" + , " let helper :: Xxx" + , " helper = undefined" + , " in helper" + ] + (Position 5 19) -- after "Xxx" in " let helper :: Xxx" + [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)] + + , testSessionSingleFile "nested non-type signature gives value completions" "A.hs" + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + -- the type shares the value's prefix, so only the context filter excludes it. + , "data Barrvaltype = Barrcon" + , "foo = barrval" + , " where" + , " barrval = ()" + , " {-# INLINE barrval #-}" + ]) $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 6 20) -- after "barrv" in the INLINE pragma + let labels = map (^. L.label) compls + liftIO $ assertBool "barrval should appear (a pragma sig is not a type context)" + ("barrval" `elem` labels) + liftIO $ assertBool "Barrvaltype should not appear in value context" + (not ("Barrvaltype" `elem` labels)) + + , testSessionSingleFile "export list gives value completions" "A.hs" + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (xxx) where" + , "xxx = ()" + , "unused = ()" -- forces a warning so waitForDiagnostics has something to wait on + ]) $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 1 12) -- inside the export list, within "xxx" + let labels = map (^. L.label) compls + liftIO $ assertBool "xxx should be completable in the export list" ("xxx" `elem` labels) + + , testSessionSingleFile "export list offers type completions" "A.hs" + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A (Xxx) where" + , "data Xxxtype = Xxxcon" + , "unused = ()" -- forces a warning so waitForDiagnostics has something to wait on + ]) $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 1 12) -- inside the export list, within "Xxx" + let labels = map (^. L.label) compls + liftIO $ assertBool "the type Xxxtype should be completable in the export list" + ("Xxxtype" `elem` labels) + + , testSessionSingleFile "import list gives module-export completions" "A.hs" + (T.unlines + [ "module A where" + , "import Data.List (per)" + ]) $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 1 21) -- inside the import list, after "per" + let labels = map (^. L.label) compls + liftIO $ assertBool "permutations should complete inside the import list" + ("permutations" `elem` labels) + + , testSessionSingleFile "import hiding list gives module-export completions" "A.hs" + (T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + , "import Data.List hiding (per)" + , "unused = ()" -- force a warning to wait on with waitForDiagnostics + ]) $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 28) -- inside the hiding list, after "per" + let labels = map (^. L.label) compls + liftIO $ assertBool "permutations should complete inside the hiding list" + ("permutations" `elem` labels) + ] + completionDocTests :: [TestTree] completionDocTests = [ testSessionEmpty "local define" $ do diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 6098498701..fcbfef9c90 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -174,6 +174,7 @@ library Development.IDE.Monitoring.OpenTelemetry Development.IDE.Plugin Development.IDE.Plugin.Completions + Development.IDE.Plugin.Completions.Context Development.IDE.Plugin.Completions.Types Development.IDE.Plugin.Completions.Logic Development.IDE.Plugin.HLS diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 3f55037399..65c7015fc5 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -8,57 +8,59 @@ module Development.IDE.Plugin.Completions , ghcideCompletionsPluginPriority ) where -import Control.Concurrent.Async (concurrently) -import Control.Concurrent.STM.Stats (readTVarIO) -import Control.Lens ((&), (.~), (?~)) +import Control.Concurrent.Async (concurrently) +import Control.Concurrent.STM.Stats (readTVarIO) +import Control.Lens ((&), (.~), (?~)) import Control.Monad.IO.Class -import Control.Monad.Trans.Except (ExceptT (ExceptT), - withExceptT) -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set +import Control.Monad.Trans.Except (ExceptT (ExceptT), + withExceptT) +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set import Data.Maybe -import qualified Data.Text as T +import qualified Data.Text as T import Development.IDE.Core.Compile -import Development.IDE.Core.FileStore (getUriContents) +import Development.IDE.Core.FileStore (getUriContents) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service hiding (Log, LogShake) -import Development.IDE.Core.Shake hiding (Log, - knownTargets) -import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Core.Service hiding (Log, + LogShake) +import Development.IDE.Core.Shake hiding (Log, + knownTargets) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import Development.IDE.Graph +import Development.IDE.Plugin.Completions.Context (deduceContext) import Development.IDE.Plugin.Completions.Logic import Development.IDE.Plugin.Completions.Types import Development.IDE.Spans.Common import Development.IDE.Spans.Documentation import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports, envVisibleModuleNames), - hscEnv) -import qualified Development.IDE.Types.KnownTargets as KT +import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports, envVisibleModuleNames), + hscEnv) +import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location -import Ide.Logger (Pretty (pretty), - Recorder, - WithPriority, - cmapWithPrio) +import Ide.Logger (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio) import Ide.Plugin.Error import Ide.Types -import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Numeric.Natural -import Prelude hiding (mod) -import Text.Fuzzy.Parallel (Scored (..)) +import Prelude hiding (mod) +import Text.Fuzzy.Parallel (Scored (..)) -import Development.IDE.Core.Rules (usePropertyAction) +import Development.IDE.Core.Rules (usePropertyAction) -import qualified Ide.Plugin.Config as Config +import qualified Ide.Plugin.Config as Config -import Development.IDE.Types.Options (LinkTargets (..), - linkTargets) -import qualified GHC.LanguageExtensions as LangExt +import Development.IDE.Types.Options (LinkTargets (..), + linkTargets) +import qualified GHC.LanguageExtensions as LangExt data Log = LogShake Shake.Log deriving Show @@ -208,9 +210,10 @@ getCompletionsLSP ide plId (_, _) -> do let clientCaps = clientCapabilities $ shakeExtras ide plugins = idePlugins $ shakeExtras ide + context = deduceContext parsedMod position config <- liftIO $ runAction "" ide $ getCompletionsConfig plId - let allCompletions = getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri + let allCompletions = getCompletions plugins ideOpts cci' context astres bindMap pfix clientCaps config moduleExports uri pure $ InL (orderedCompletions allCompletions) _ -> return (InL []) _ -> return (InL []) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs new file mode 100644 index 0000000000..86fbce063c --- /dev/null +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} + +-- | Completion-context detection. Given a parsed module and a cursor position, +-- determine a context the cursor sits in so the completion logic can pick which +-- completions to offer. +module Development.IDE.Plugin.Completions.Context + ( Context (..) + , contextFilter + , deduceContext + , getContext + ) where + +import Data.Generics (GenericQ, extQ, gmapQ, + mkQ) +import Data.Maybe (maybeToList) +import qualified Data.Text as T +import Development.IDE +import Development.IDE.Core.PositionMapping +import Development.IDE.GHC.Compat hiding (getContext) +import Language.LSP.Protocol.Types (isSubrangeOf) + +#if !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif + +#if MIN_VERSION_ghc(9,9,0) +import GHC.Hs (HasLoc) +#endif + +-- | The kind of context the cursor sits in used to pick which completions to +-- show. +data Context + = TypeContext + | ValueContext + | -- | The module's name of an import. + ImportModuleContext T.Text + | -- | Import context (explicit or hiding) with module name. + ImportListContext T.Text + | -- | The export list of the current module. + ExportContext + | -- | Fallback. Show all known symbols. + DefaultContext + deriving (Show, Eq) + +data ContextResult = NoContext | ContextResult !Range !Context + +-- | Keep the innermost of two results. +tighten :: ContextResult -> ContextResult -> ContextResult +tighten NoContext b = b +tighten a NoContext = a +tighten ar@(ContextResult a _) br@(ContextResult b _) + | b `isSubrangeOf` a = br + | otherwise = ar + +foldTighten :: (a -> ContextResult) -> [a] -> ContextResult +foldTighten f = foldr (tighten . f) NoContext + +-- | Filter completions for a context. The predicate reports whether a candidate +-- is a type-level name. An export list accepts both, so it is unfiltered. Import +-- contexts are dispatched by getCompletions before this runs and never reach +-- here. +contextFilter :: (a -> Bool) -> Context -> [a] -> [a] +contextFilter isTypeCompl ctx = case ctx of + TypeContext -> filter isTypeCompl + ValueContext -> filter (not . isTypeCompl) + DefaultContext -> id + ExportContext -> id + ImportModuleContext{} -> dispatchedEarlier + ImportListContext{} -> dispatchedEarlier + where + dispatchedEarlier = id + +-- | Look up the completion context at the given position, accounting for stale +-- data via the position mapping. +deduceContext :: Maybe (ParsedModule, PositionMapping) -> Position -> Context +deduceContext Nothing _ = DefaultContext +deduceContext (Just (pm, pmapping)) pos = + let PositionMapping pDelta = pmapping + in getContext pm (fromDelta pDelta pos) + +-- | Determine the completion 'Context' at the cursor, returning the innermost +-- (most specific) declaration that contains it, or 'DefaultContext' if none do. +getContext :: ParsedModule -> PositionResult Position -> Context +getContext pm query = + case foldTighten (getExportContext q) (maybeToList hsmodExports) + `tighten` foldTighten (getImportContext q) hsmodImports + `tighten` foldTighten (getDeclContext q) hsmodDecls of + NoContext -> DefaultContext + ContextResult _ found -> found + where + q = case query of + PositionExact p -> Range p p + PositionRange l u -> Range l u + HsModule {hsmodExports, hsmodImports, hsmodDecls} = unLoc (pm_parsed_source pm) + +getExportContext :: Range -> XRec GhcPs [LIE GhcPs] -> ContextResult +getExportContext = contextual ExportContext + +getImportContext :: Range -> LImportDecl GhcPs -> ContextResult +getImportContext query limp@(L _ imp) = + let modName = T.pack $ moduleNameString $ unLoc $ ideclName imp + inline = case ideclImportList imp of + Just (_, l) -> contextual (ImportListContext modName) query l + Nothing -> NoContext + in inline `tighten` contextual (ImportModuleContext modName) query limp + +getDeclContext :: Range -> LHsDecl GhcPs -> ContextResult +getDeclContext query = + gather (mkQ (NoContext, False) (declQ query) `extQ` sigQ query `extQ` bindQ query `extQ` typeQ query) + +-- * SYB query types + +-- | Does this signature carry a type? Fixity, INLINE, MINIMAL and similar +-- pragmas do not. +typeSig :: Sig GhcPs -> Bool +typeSig TypeSig {} = True +typeSig ClassOpSig {} = True +typeSig PatSynSig {} = True +typeSig _ = False + +-- | Classify a top-level declaration. +declQ :: Range -> LHsDecl GhcPs -> (ContextResult, Bool) +declQ query decl'@(L _ decl) = + contInRange query (rangeOf decl') $ \declRange -> case decl of + SigD _ sig | typeSig sig -> (ContextResult declRange TypeContext, True) + ValD {} -> (ContextResult declRange ValueContext, False) + _ -> (NoContext, False) + +-- | A signature reached by descent (local, class, or instance). Only the +-- type-bearing ones are a type context. +sigQ :: Range -> LSig GhcPs -> (ContextResult, Bool) +sigQ query lsig@(L _ sig) + | typeSig sig = stopAt TypeContext query lsig + | otherwise = (NoContext, False) + +bindQ :: Range -> LHsBind GhcPs -> (ContextResult, Bool) +bindQ query = descendInto ValueContext query + +typeQ :: Range -> LHsType GhcPs -> (ContextResult, Bool) +typeQ query = stopAt TypeContext query + +#if MIN_VERSION_ghc(9,9,0) +stopAt, descendInto :: HasLoc a => Context -> Range -> a -> (ContextResult, Bool) +contextual :: HasLoc a => Context -> Range -> a -> ContextResult +#else +stopAt, descendInto :: Context -> Range -> GenLocated (SrcSpanAnn' a) e -> (ContextResult, Bool) +contextual :: Context -> Range -> GenLocated (SrcSpanAnn' a) e -> ContextResult +#endif +-- | Match a node and stop descending (its whole range is the context). +stopAt context query s = + contInRange query (rangeOf s) $ \range -> (ContextResult range context, True) +-- | Match a node and keep descending, so a tighter inner node can win. +descendInto context query s = + contInRange query (rangeOf s) $ \range -> (ContextResult range context, False) +-- | The result of 'stopAt' without the descent flag, for non-SYB callers. +contextual context query s = fst (stopAt context query s) + +-- | Run a continuation with the 'Range' of a source span, returning no context +-- if the span is missing or does not contain the query range. +contInRange :: Range -> Maybe Range -> (Range -> (ContextResult, Bool)) -> (ContextResult, Bool) +contInRange query range k = case range of + Just range' | within query range' -> k range' + _ -> (NoContext, True) + +-- * Helpers + +-- | The trailing edge is widened to the end of the source's final line, so +-- a cursor past the last token on a line still counts as inside the node +-- occupying that line. +within :: Range -> Range -> Bool +within query (Range start end) = + query `isSubrangeOf` Range start (end { _character = maxBound }) + +#if MIN_VERSION_ghc(9,9,0) +rangeOf :: HasLoc a => a -> Maybe Range +rangeOf = srcSpanToRange . locA +#else +rangeOf :: GenLocated (SrcSpanAnn' a) e -> Maybe Range +rangeOf = srcSpanToRange . getLocA +#endif + +-- | Variation of @Data.Generics.Schemes.everythingBut@ that combines with +-- 'tighten' and folds strictly. +gather :: GenericQ (ContextResult, Bool) -> GenericQ ContextResult +gather f = go + where + go :: GenericQ ContextResult + go x = let (v, stop) = f x + in if stop then v else foldl' tighten v (gmapQ go x) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 3fe20d24b9..ce4ff41e85 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -14,66 +14,67 @@ module Development.IDE.Plugin.Completions.Logic ( , getCompletionPrefixFromRope ) where -import Control.Applicative -import Control.Lens hiding (Context, - parts) -import Data.Char (isAlphaNum, isUpper) -import Data.Default (def) +import Control.Lens hiding (Context, + parts) +import Data.Char (isAlphaNum, + isUpper) import Data.Generics -import Data.List.Extra as List hiding - (stripPrefix) -import qualified Data.Map as Map -import Prelude hiding (mod) - -import Data.Maybe (fromMaybe, isJust, - isNothing, - listToMaybe, - mapMaybe) -import qualified Data.Text as T -import qualified Text.Fuzzy.Parallel as Fuzzy +import Data.List.Extra as List hiding + (stripPrefix) +import qualified Data.Map as Map +import Prelude hiding (mod) + +import Data.Maybe (fromMaybe, isJust, + isNothing, + listToMaybe, + mapMaybe) +import qualified Data.Text as T +import qualified Text.Fuzzy.Parallel as Fuzzy import Control.Monad -import Data.Aeson (ToJSON (toJSON)) -import Data.Function (on) +import Data.Aeson (ToJSON (toJSON)) +import Data.Function (on) -import qualified Data.HashSet as HashSet -import Data.Ord (Down (Down)) -import qualified Data.Set as Set +import qualified Data.HashSet as HashSet +import Data.Ord (Down (Down)) +import qualified Data.Set as Set import Development.IDE.Core.PositionMapping -import Development.IDE.GHC.Compat hiding (isQual, ppr) -import qualified Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat hiding (isQual, ppr) +import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util +import Development.IDE.Plugin.Completions.Context (Context (..), + contextFilter) import Development.IDE.Plugin.Completions.Types import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Exports import Development.IDE.Types.Options -import GHC.Iface.Ext.Types (HieAST, - NodeInfo (..)) -import GHC.Iface.Ext.Utils (nodeInfo) -import Ide.PluginUtils (mkLspCommand) -import Ide.Types (CommandId (..), - IdePlugins (..), - PluginId) +import GHC.Iface.Ext.Types (HieAST, + NodeInfo (..)) +import GHC.Iface.Ext.Utils (nodeInfo) +import Ide.PluginUtils (mkLspCommand) +import Ide.Types (CommandId (..), + IdePlugins (..), + PluginId) import Language.Haskell.Syntax.Basic -import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types -import qualified Language.LSP.VFS as VFS -import Text.Fuzzy.Parallel (Scored (score), - original) +import qualified Language.LSP.VFS as VFS +import Text.Fuzzy.Parallel (Scored (score), + original) -import qualified Data.Text.Utf16.Rope.Mixed as Rope -import Development.IDE hiding (line) +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE hiding (line) -import Development.IDE.Spans.AtPoint (pointCommand) +import Development.IDE.Spans.AtPoint (pointCommand) -import qualified Development.IDE.Plugin.Completions.Types as C -import GHC.Plugins (Depth (AllTheWay), - mkUserStyle, - neverQualify, - sdocStyle) +import qualified Development.IDE.Plugin.Completions.Types as C +import GHC.Plugins (Depth (AllTheWay), + mkUserStyle, + neverQualify, + sdocStyle) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -82,82 +83,6 @@ import GHC.Plugins (Depth (AllTheWay), chunkSize :: Int chunkSize = 1000 --- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs - --- | A context of a declaration in the program --- e.g. is the declaration a type declaration or a value declaration --- Used for determining which code completions to show --- TODO: expand this with more contexts like classes or instances for --- smarter code completion -data Context = TypeContext - | ValueContext - | ModuleContext String -- ^ module context with module name - | ImportContext String -- ^ import context with module name - | ImportListContext String -- ^ import list context with module name - | ImportHidingContext String -- ^ import hiding context with module name - | ExportContext -- ^ List of exported identifiers from the current module - deriving (Show, Eq) - --- | Generates a map of where the context is a type and where the context is a value --- i.e. where are the value decls and the type decls -getCContext :: Position -> ParsedModule -> Maybe Context -getCContext pos pm - | Just (L (locA -> r) modName) <- moduleHeader - , pos `isInsideSrcSpan` r - = Just (ModuleContext (moduleNameString modName)) - - | Just (L (locA -> 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 (locA -> r) SigD {}) - | pos `isInsideSrcSpan` r = Just TypeContext - | otherwise = Nothing - go (L (locA -> r) GHC.ValD {}) - | pos `isInsideSrcSpan` r = Just ValueContext - | otherwise = Nothing - go _ = Nothing - - goInline :: GHC.LHsType GhcPs -> Maybe Context - goInline (GHC.L (locA -> r) _) - | pos `isInsideSrcSpan` r = Just TypeContext - goInline _ = Nothing - - importGo :: GHC.LImportDecl GhcPs -> Maybe Context - importGo (L (locA -> r) impDecl) - | pos `isInsideSrcSpan` r - = importInline importModuleName (fmap (fmap reLoc) $ ideclImportList 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 (EverythingBut, L r _)) - | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName - | otherwise = Nothing - - importInline modName (Just (Exactly, L r _)) - | pos `isInsideSrcSpan` r = Just $ ImportListContext modName - | otherwise = Nothing - - importInline _ _ = Nothing - occNameToComKind :: OccName -> CompletionItemKind occNameToComKind oc | isVarOcc oc = case occNameString oc of @@ -286,11 +211,6 @@ mkExtCompl label = defaultCompletionItemWithLabel label & L.kind ?~ CompletionItemKind_Keyword -defaultCompletionItemWithLabel :: T.Text -> CompletionItem -defaultCompletionItemWithLabel label = - CompletionItem label def def def def def def def def def - def def def def def def def def def - fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem fromIdentInfo doc identInfo@IdentInfo{..} q = CI { compKind= occNameToComKind name @@ -529,7 +449,7 @@ getCompletions :: IdePlugins a -> IdeOptions -> CachedCompletions - -> Maybe (ParsedModule, PositionMapping) + -> Context -> Maybe (HieAstResult, PositionMapping) -> (Bindings, PositionMapping) -> PosPrefixInfo @@ -542,7 +462,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} - maybe_parsed + context maybe_ast_res (localBindings, bmapping) prefixInfo@(PosPrefixInfo { fullLine, prefixScope, prefixText }) @@ -551,16 +471,13 @@ getCompletions moduleExportsMap uri -- ------------------------------------------------------------------------ - -- IMPORT MODULENAME (NAM|) - | Just (ImportListContext moduleName) <- maybeContext - = moduleImportListCompletions moduleName - - | Just (ImportHidingContext moduleName) <- maybeContext + -- IMPORT MODULENAME (NAM|) and IMPORT MODULENAME hiding (NAM|) + | ImportListContext moduleName <- context = moduleImportListCompletions moduleName -- ------------------------------------------------------------------------ -- IMPORT MODULENAM| - | Just (ImportContext _moduleName) <- maybeContext + | ImportModuleContext _ <- context = filtImportCompls -- ------------------------------------------------------------------------ @@ -607,17 +524,6 @@ getCompletions $ Fuzzy.simpleFilter chunkSize maxC fullPrefix $ (if T.null enteredQual then id else mapMaybe (T.stripPrefix enteredQual)) allModNamesAsNS - -- If we have a parsed module, use it to determine which completion to show. - maybeContext :: Maybe Context - maybeContext = 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 - filtCompls :: [Scored (Bool, CompItem)] filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls (label . snd) where @@ -657,12 +563,9 @@ getCompletions , isLocalCompletion = False }) - -- completions specific to the current context - ctxCompls' = case maybeContext of - Nothing -> compls - Just TypeContext -> filter ( isTypeCompl . snd) compls - Just ValueContext -> filter (not . isTypeCompl . snd) compls - Just _ -> filter (not . isTypeCompl . snd) compls + -- Completions for the current context. The import contexts are + -- handled by earlier guards and never reach this point. + ctxCompls' = contextFilter (isTypeCompl . snd) context compls -- Add whether the text to insert has backticks ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls' @@ -699,12 +602,11 @@ getCompletions , enteredQual `T.isPrefixOf` original label ] - moduleImportListCompletions :: String -> [Scored CompletionItem] - moduleImportListCompletions moduleNameS = - let moduleName = T.pack moduleNameS - funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName moduleNameS - funs = map (show . name) $ HashSet.toList funcs - in filterModuleExports moduleName $ map T.pack funs + moduleImportListCompletions :: T.Text -> [Scored CompletionItem] + moduleImportListCompletions moduleName = + let funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName (T.unpack moduleName) + funs = map (T.pack . show . name) $ HashSet.toList funcs + in filterModuleExports moduleName funs filtImportCompls :: [Scored CompletionItem] filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs index 698003786c..d764013b47 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs @@ -14,6 +14,7 @@ import qualified Data.Text as T import Data.Aeson import Data.Aeson.Types +import Data.Default (def) import Data.Function (on) import Data.Hashable (Hashable) import qualified Data.List as L @@ -26,7 +27,8 @@ import Development.IDE.Spans.Common () import GHC.Generics (Generic) import qualified GHC.Types.Name.Occurrence as Occ import Ide.Plugin.Properties -import Language.LSP.Protocol.Types (CompletionItemKind (..), Uri) +import Language.LSP.Protocol.Types (CompletionItem (..), + CompletionItemKind (..), Uri) import qualified Language.LSP.Protocol.Types as J -- | Produce completions info for a file @@ -151,6 +153,11 @@ data CompItem = CI } deriving (Eq, Show) +defaultCompletionItemWithLabel :: T.Text -> CompletionItem +defaultCompletionItemWithLabel label = + CompletionItem label def def def def def def def def def + def def def def def def def def def + -- Associates a module's qualifier with its members newtype QualCompls = QualCompls { getQualCompls :: Map.Map T.Text [CompItem] }