From 9fad2a27c5fcec79e093659357687de3fb39c962 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Sun, 19 Apr 2026 21:36:52 +0200 Subject: [PATCH 01/21] Create context tree based on parsed module results In the pursuit of smarter completions, create context trees that can be used as masks for easier filtering of relevant completions based on the line number. --- ghcide/ghcide.cabal | 1 + .../IDE/Plugin/Completions/Context.hs | 142 ++++++++++++++++++ .../IDE/Plugin/Completions/Logic.hs | 4 +- 3 files changed, 144 insertions(+), 3 deletions(-) create mode 100644 ghcide/src/Development/IDE/Plugin/Completions/Context.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 18091e2ddc..9f96e280a9 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/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs new file mode 100644 index 0000000000..d9f62f7e3f --- /dev/null +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE TypeFamilies #-} + +module Development.IDE.Plugin.Completions.Context where + +import Control.DeepSeq (NFData (..), rwhnf) +import Data.Hashable (Hashable) +import qualified Data.IntervalMap.FingerTree as IM +import Data.List (maximumBy) +import Data.Maybe (maybeToList) +import Data.Ord (Down (..), comparing) +import qualified Data.Text as T +import Development.IDE +import Development.IDE.GHC.Compat +import GHC.Generics (Generic) +import Ide.Plugin.RangeMap (RangeMap (..), fromList') +import Development.IDE.GHC.Compat.Util (bagToList) +import Development.IDE.Core.PositionMapping + +-- | 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 + | -- | module context with module name + ModuleContext T.Text + | -- | import context with module name + ImportContext T.Text + | -- | import list context with module name + ImportListContext T.Text + | -- | import hiding context with module name + ImportHidingContext T.Text + | -- | List of exported identifiers from the current module + ExportContext + | -- | Top-level context + TopContext + | -- | Unsupported context, a placeholder context where we give up being smart + -- and show all known symbols. + DefaultContext + deriving (Show, Eq) + +data GetContextTree = GetContextTree + deriving (Eq, Show, Generic) +instance Hashable GetContextTree +instance NFData GetContextTree +type instance RuleResult GetContextTree = ContextTree + +newtype ContextTree = ContextTree {contextTree :: RangeMap Context} + +instance Show ContextTree where show _ = "" +instance NFData ContextTree where rnf = rwhnf + +-- | Build a 'ContextTree' from a parsed module. +-- +-- Walks module header, exports, imports, and top-level declarations +-- (one level into class bodies). Built once per file edit and cached +-- as a Shake rule. +-- +-- TODO: Would be nice if this would be updated incrementally. Most of the time +-- edits occur in unrelated parts of the module, meaning the largest proportion of +-- this tree doesn't require changing. +-- +-- Could be done by tracking the 'dirtied' parts of a file using didChange and +-- 'refreshing' and doing a lighter weight traversal across the parsed module. +getContextTree :: ParsedModule -> ContextTree +getContextTree pm = ContextTree $ fromList' entries + where + HsModule{hsmodName, hsmodExports, hsmodImports, hsmodDecls} = + unLoc (pm_parsed_source pm) + + entries :: [(Range, Context)] + entries = moduleEntry ++ exportEntry ++ importEntries ++ declEntries + + -- Module name keyword span -> ModuleContext + moduleEntry = case hsmodName of + Just (L (locA -> ss) modName) -> + maybeToList $ (, ModuleContext (T.pack $ moduleNameString modName)) <$> srcSpanToRange ss + Nothing -> [] + + -- Export list -> ExportContext + exportEntry = case hsmodExports of + Just (L (locA -> ss) _) -> + maybeToList $ (, ExportContext) <$> srcSpanToRange ss + Nothing -> [] + + -- Each import declaration + importEntries = foldMap importEntry hsmodImports + + importEntry :: LImportDecl GhcPs -> [(Range, Context)] + importEntry (L (locA -> ss) impDecl) = + let modName = T.pack $ moduleNameString $ unLoc $ ideclName impDecl + outerCtx = (, ImportContext modName) <$> srcSpanToRange ss + innerCtx = importListEntry modName (fmap (fmap reLoc) $ ideclImportList impDecl) + in maybeToList outerCtx ++ innerCtx + + importListEntry :: T.Text -> Maybe (ImportListInterpretation, Located [LIE GhcPs]) -> [(Range, Context)] + importListEntry modName (Just (EverythingBut, L ss _)) = + maybeToList $ (, ImportHidingContext modName) <$> srcSpanToRange ss + importListEntry modName (Just (Exactly, L ss _)) = + maybeToList $ (, ImportListContext modName) <$> srcSpanToRange ss + importListEntry _ _ = [] + + -- Top-level declarations + declEntries = concatMap declEntry hsmodDecls + + declEntry :: LHsDecl GhcPs -> [(Range, Context)] + declEntry (L (locA -> ss) decl) = case srcSpanToRange ss of + Nothing -> [] + Just range -> case decl of + SigD {} -> [(range, TypeContext)] + ValD {} -> [(range, ValueContext)] + TyClD _ cd@ClassDecl{} -> (range, TypeContext) : classEntries cd + TyClD {} -> [(range, TypeContext)] -- DataDecl, SynDecl, FamilyDecl + InstD {} -> [(range, ValueContext)] + DerivD {} -> [(range, TypeContext)] + ForD {} -> [(range, ValueContext)] + _ -> [(range, DefaultContext)] -- DefD, WarningD, AnnD, RuleD, SpliceD, DocD, KindSigD + + -- One level into class bodies: method sigs and default implementations + classEntries :: TyClDecl GhcPs -> [(Range, Context)] + classEntries ClassDecl{tcdSigs, tcdMeths} = + [ (r, TypeContext) + | L (locA -> ss) _ <- tcdSigs + , Just r <- [srcSpanToRange ss] + ] ++ + [ (r, ValueContext) + | L (locA -> ss) _ <- bagToList tcdMeths + , Just r <- [srcSpanToRange ss] + ] + classEntries _ = [] + +-- | Look up the completion context at a given position. +-- Returns the innermost (most specific) context that contains the position. +getContext :: ContextTree -> PositionResult Position -> Context +getContext (ContextTree (RangeMap im)) pos = + case IM.dominators pointInterval im of + [] -> TopContext + xs -> snd $ maximumBy (comparing (\(iv, _) -> (IM.low iv, Down (IM.high iv)))) xs + where + pointInterval = case pos of + PositionExact p -> IM.Interval p p + PositionRange l u -> IM.Interval l u diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 3fe20d24b9..c6a4121dc1 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -96,6 +96,7 @@ data Context = TypeContext | 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 + | TopContext -- Top-level context deriving (Show, Eq) -- | Generates a map of where the context is a type and where the context is a value @@ -730,9 +731,6 @@ getCompletions let isLocal = maybe False (":" `T.isPrefixOf`) _detail (Down isQual, Down score, Down isLocal, _label, _detail) - - - uniqueCompl :: CompItem -> CompItem -> Ordering uniqueCompl candidate unique = case compare (label candidate, compKind candidate) From faaebaf9d0a83951205efe168ebd99156d0bbecb Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Sun, 19 Apr 2026 21:40:04 +0200 Subject: [PATCH 02/21] Add top-level declaration snippet completer --- ghcide/ghcide.cabal | 1 + .../IDE/Plugin/Completions/Snippet.hs | 59 +++++++++++++++++++ 2 files changed, 60 insertions(+) create mode 100644 ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 9f96e280a9..2df63cd392 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -175,6 +175,7 @@ library Development.IDE.Plugin Development.IDE.Plugin.Completions Development.IDE.Plugin.Completions.Context + Development.IDE.Plugin.Completions.Snippet Development.IDE.Plugin.Completions.Types Development.IDE.Plugin.Completions.Logic Development.IDE.Plugin.HLS diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs b/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs new file mode 100644 index 0000000000..f152e2e76c --- /dev/null +++ b/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs @@ -0,0 +1,59 @@ +module Development.IDE.Plugin.Completions.Snippet where + +import Control.Lens +import Data.String (IsString) +import Data.Text (Text) +import Development.IDE.Plugin.Completions.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types + +data SnippetCompletion = SnippetCompletion + { snippetLabel :: {-# UNPACK #-} !Text, + snippetDetail :: {-# UNPACK #-} !Text, + -- | Might be good to use the structured snippets instead of bare text. + -- This is fine for now though, none of the top-level snippet completions are + -- parameterized. + snippetContents :: {-# UNPACK #-} !Text + } + +topContextSnippets :: [SnippetCompletion] +topContextSnippets = + [ SnippetCompletion "import" "import module" importUnqualifiedSnippet, + SnippetCompletion "import" "import module (explicit list)" importExplicitSnippet, + SnippetCompletion "import" "import module hiding" importHidingSnippet, + SnippetCompletion "import" "import module qualified as" importQualifiedAsSnippet, + SnippetCompletion "function" "function definition" functionDefinitionSnippet, + SnippetCompletion "class" "class declaration" classDeclarationSnippet, + SnippetCompletion "instance" "instance declaration" instanceDeclarationSnippet + ] + +mkTopSnippetCompl :: SnippetCompletion -> CompletionItem +mkTopSnippetCompl SnippetCompletion {..} = + defaultCompletionItemWithLabel snippetLabel + & L.kind ?~ CompletionItemKind_Snippet + & L.detail ?~ snippetDetail + & L.insertText ?~ snippetContents + & L.insertTextFormat ?~ InsertTextFormat_Snippet + +importUnqualifiedSnippet :: (IsString s) => s +importUnqualifiedSnippet = "import ${1:module}" + +importExplicitSnippet :: (IsString s) => s +importExplicitSnippet = "import ${1:module} (${2:names})" + +importHidingSnippet :: (IsString s) => s +importHidingSnippet = "import ${1:module} hiding (${2:names})" + +importQualifiedAsSnippet :: (IsString s) => s +importQualifiedAsSnippet = "import ${1:module} qualified as ${2:alias}" + +functionDefinitionSnippet :: (IsString s) => s +functionDefinitionSnippet = + "${1:identifier} :: ${2:type}\n\ + \${1:identifier} = ${3:body}" + +classDeclarationSnippet :: (IsString s) => s +classDeclarationSnippet = "class ${1:name} where" + +instanceDeclarationSnippet :: (IsString s) => s +instanceDeclarationSnippet = "instance ${1:name} where" From cf45f1ea8cc88d085aa65ffe234121847590b202 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Sun, 19 Apr 2026 21:41:15 +0200 Subject: [PATCH 03/21] Use context trees when filtering completions --- .../src/Development/IDE/Plugin/Completions.hs | 65 ++--- .../IDE/Plugin/Completions/Context.hs | 39 +-- .../IDE/Plugin/Completions/Logic.hs | 228 ++++++------------ .../IDE/Plugin/Completions/Types.hs | 29 ++- 4 files changed, 152 insertions(+), 209 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index de90d458fa..9e1c5e7ba4 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -8,55 +8,57 @@ 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 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 qualified GHC.LanguageExtensions as LangExt +import qualified GHC.LanguageExtensions as LangExt data Log = LogShake Shake.Log deriving Show @@ -89,6 +91,9 @@ produceCompletions recorder = do let cdata = localCompletionsForParsedModule uri pm return ([], Just cdata) _ -> return ([], Nothing) + define (cmapWithPrio LogShake recorder) $ \GetContextTree file -> do + mbPm <- useWithStale GetParsedModule file + return ([], getContextTree . fst <$> mbPm) define (cmapWithPrio LogShake recorder) $ \NonLocalCompletions file -> do -- For non local completions we avoid depending on the parsed module, -- synthesizing a fake module with an empty body from the buffer @@ -170,7 +175,7 @@ getCompletionsLSP ide plId opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide localCompls <- useWithStaleFast LocalCompletions npath nonLocalCompls <- useWithStaleFast NonLocalCompletions npath - pm <- useWithStaleFast GetParsedModule npath + ctxTree <- useWithStaleFast GetContextTree npath binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath knownTargets <- liftIO $ runAction "Completion" ide $ useNoFile GetKnownTargets let localModules = maybe [] (Map.keys . targetMap) knownTargets @@ -194,9 +199,9 @@ getCompletionsLSP ide plId -> useWithStaleFast GetHieAst npath _ -> return Nothing - pure (opts, fmap (,pm,binds) compls, moduleExports, astres) + pure (opts, fmap (,ctxTree,binds) compls, moduleExports, astres) case compls of - Just (cci', parsedMod, bindMap) -> do + Just (cci', ctxTree, bindMap) -> do let pfix = getCompletionPrefixFromRope position cnts case (pfix, completionContext) of (PosPrefixInfo _ "" _ _, Just CompletionContext { _triggerCharacter = Just "."}) @@ -206,7 +211,7 @@ getCompletionsLSP ide plId plugins = idePlugins $ shakeExtras ide 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' ctxTree 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 index d9f62f7e3f..4dc41cfa2d 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -2,19 +2,19 @@ module Development.IDE.Plugin.Completions.Context where -import Control.DeepSeq (NFData (..), rwhnf) -import Data.Hashable (Hashable) -import qualified Data.IntervalMap.FingerTree as IM -import Data.List (maximumBy) -import Data.Maybe (maybeToList) -import Data.Ord (Down (..), comparing) -import qualified Data.Text as T +import Control.DeepSeq (NFData (..), rwhnf) +import Data.Hashable (Hashable) +import qualified Data.IntervalMap.FingerTree as IM +import Data.List (maximumBy) +import Data.Maybe (maybeToList) +import Data.Ord (Down (..), comparing) +import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat -import GHC.Generics (Generic) -import Ide.Plugin.RangeMap (RangeMap (..), fromList') -import Development.IDE.GHC.Compat.Util (bagToList) -import Development.IDE.Core.PositionMapping +import Development.IDE.GHC.Compat.Util (bagToList) +import GHC.Generics (Generic) +import Ide.Plugin.RangeMap (RangeMap (..), fromList') -- | A context of a declaration in the program -- e.g. is the declaration a type declaration or a value declaration @@ -107,14 +107,15 @@ getContextTree pm = ContextTree $ fromList' entries declEntry (L (locA -> ss) decl) = case srcSpanToRange ss of Nothing -> [] Just range -> case decl of - SigD {} -> [(range, TypeContext)] - ValD {} -> [(range, ValueContext)] + SigD {} -> [(range, TypeContext)] + ValD {} -> [(range, ValueContext)] TyClD _ cd@ClassDecl{} -> (range, TypeContext) : classEntries cd - TyClD {} -> [(range, TypeContext)] -- DataDecl, SynDecl, FamilyDecl - InstD {} -> [(range, ValueContext)] - DerivD {} -> [(range, TypeContext)] - ForD {} -> [(range, ValueContext)] - _ -> [(range, DefaultContext)] -- DefD, WarningD, AnnD, RuleD, SpliceD, DocD, KindSigD + TyClD {} -> [(range, TypeContext)] -- DataDecl, SynDecl, FamilyDecl + InstD {} -> [(range, ValueContext)] + DerivD {} -> [(range, TypeContext)] + ForD {} -> [(range, ValueContext)] + SpliceD {} -> [(range, TopContext)] + _ -> [(range, DefaultContext)] -- DefD, WarningD, AnnD, RuleD, DocD, KindSigD -- One level into class bodies: method sigs and default implementations classEntries :: TyClDecl GhcPs -> [(Range, Context)] @@ -138,5 +139,5 @@ getContext (ContextTree (RangeMap im)) pos = xs -> snd $ maximumBy (comparing (\(iv, _) -> (IM.low iv, Down (IM.high iv)))) xs where pointInterval = case pos of - PositionExact p -> IM.Interval p p + PositionExact p -> IM.Interval p p PositionRange l u -> IM.Interval l u diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index c6a4121dc1..6fa8798d59 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -15,65 +15,69 @@ module Development.IDE.Plugin.Completions.Logic ( ) 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 (..), + ContextTree) +import qualified Development.IDE.Plugin.Completions.Context as Context +import Development.IDE.Plugin.Completions.Snippet 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,83 +86,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 - | TopContext -- Top-level context - 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 @@ -287,11 +214,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 @@ -330,7 +252,6 @@ cacheDataProducer uri visibleMods curMod globalEnv inScopeEnv limports = -- Full canonical names of imported modules importDeclarations = map unLoc limports - -- The given namespaces for the imported modules (ie. full name, or alias if used) allModNamesAsNS = map (showModName . asNamespace) importDeclarations @@ -530,7 +451,7 @@ getCompletions :: IdePlugins a -> IdeOptions -> CachedCompletions - -> Maybe (ParsedModule, PositionMapping) + -> Maybe (ContextTree, PositionMapping) -> Maybe (HieAstResult, PositionMapping) -> (Bindings, PositionMapping) -> PosPrefixInfo @@ -543,7 +464,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} - maybe_parsed + maybe_ctx maybe_ast_res (localBindings, bmapping) prefixInfo@(PosPrefixInfo { fullLine, prefixScope, prefixText }) @@ -553,15 +474,15 @@ getCompletions uri -- ------------------------------------------------------------------------ -- IMPORT MODULENAME (NAM|) - | Just (ImportListContext moduleName) <- maybeContext + | ImportListContext moduleName <- maybeContext = moduleImportListCompletions moduleName - | Just (ImportHidingContext moduleName) <- maybeContext + | ImportHidingContext moduleName <- maybeContext = moduleImportListCompletions moduleName -- ------------------------------------------------------------------------ -- IMPORT MODULENAM| - | Just (ImportContext _moduleName) <- maybeContext + | ImportContext _ <- maybeContext = filtImportCompls -- ------------------------------------------------------------------------ @@ -571,6 +492,10 @@ getCompletions | "{-# " `T.isPrefixOf` fullLine = [] + -- ------------------------------------------------------------------------ + | TopContext <- maybeContext + = filtTopContextCompls + -- ------------------------------------------------------------------------ | otherwise = -- assumes that nubOrdBy is stable @@ -608,16 +533,15 @@ 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 + + -- If we have a context tree, use it to determine which completion to show. + maybeContext :: Context + maybeContext = case maybe_ctx of + Nothing -> DefaultContext + Just (ct, pmapping) -> + let PositionMapping pDelta = pmapping + position' = fromDelta pDelta pos + in Context.getContext ct position' filtCompls :: [Scored (Bool, CompItem)] filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls (label . snd) @@ -660,10 +584,10 @@ getCompletions -- 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 + TypeContext -> filter (isTypeCompl . snd) compls + ValueContext -> filter (not . isTypeCompl . snd) compls + DefaultContext -> compls + _ -> filter (not . isTypeCompl . snd) compls -- Add whether the text to insert has backticks ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls' @@ -700,12 +624,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 @@ -718,6 +641,13 @@ getCompletions | T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts) | otherwise = [] + filtTopContextCompls :: [Scored CompletionItem] + filtTopContextCompls + | T.null prefixScope + = fmap (fmap mkTopSnippetCompl) $ + Fuzzy.filter chunkSize maxC fullPrefix topContextSnippets snippetLabel + | otherwise = [] + -- We use this ordering to alphabetically sort suggestions while respecting -- all the previously applied ordering sources. These are: -- 1. Qualified suggestions go first diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs index 698003786c..6603f2d129 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 (Default (..)) 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 @@ -137,20 +139,25 @@ snippetLexOrd :: Snippet -> Snippet -> Ordering snippetLexOrd = compare `on` snippetToText data CompItem = CI - { compKind :: CompletionItemKind - , insertText :: Snippet -- ^ Snippet for the completion - , provenance :: Provenance -- ^ From where this item is imported from. - , label :: T.Text -- ^ Label to display to the user. - , typeText :: Maybe T.Text - , isInfix :: Maybe Backtick -- ^ Did the completion happen + { compKind :: {-# UNPACK #-} !CompletionItemKind + , insertText :: {-# UNPACK #-} !Snippet -- ^ Snippet for the completion + , provenance :: {-# UNPACK #-} !Provenance -- ^ From where this item is imported from. + , label :: {-# UNPACK #-} !T.Text -- ^ Label to display to the user. + , typeText :: !(Maybe T.Text) + , isInfix :: !(Maybe Backtick) -- ^ Did the completion happen -- in the context of an infix notation. - , isTypeCompl :: Bool - , additionalTextEdits :: Maybe ExtendImport - , nameDetails :: Maybe NameDetails -- ^ For resolving purposes - , isLocalCompletion :: Bool -- ^ Is it from this module? + , isTypeCompl :: {-# UNPACK #-} !Bool + , additionalTextEdits :: !(Maybe ExtendImport) + , nameDetails :: !(Maybe NameDetails) -- ^ For resolving purposes + , isLocalCompletion :: {-# UNPACK #-} !Bool -- ^ Is it from this module? } 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] } From 72959293f6972393e381ecf26b8b8b04aedc0b19 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Mon, 20 Apr 2026 19:58:03 +0200 Subject: [PATCH 04/21] Log detected context in completions --- .../src/Development/IDE/Plugin/Completions.hs | 21 +++++++---- .../IDE/Plugin/Completions/Context.hs | 12 +++++++ .../IDE/Plugin/Completions/Logic.hs | 35 ++++++++++--------- 3 files changed, 45 insertions(+), 23 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 9e1c5e7ba4..84644dfe4d 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -42,9 +42,11 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackag import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location import Ide.Logger (Pretty (pretty), + Priority (..), Recorder, WithPriority, - cmapWithPrio) + cmapWithPrio, + logWith) import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -58,13 +60,18 @@ import Development.IDE.Core.Rules (usePropertyAction) import qualified Ide.Plugin.Config as Config +import qualified Development.IDE.Plugin.Completions.Context as Context import qualified GHC.LanguageExtensions as LangExt -data Log = LogShake Shake.Log deriving Show +data Log + = LogShake Shake.Log + | LogDetectedContext Context + deriving Show instance Pretty Log where pretty = \case LogShake msg -> pretty msg + LogDetectedContext context -> "Completion context detected: " <> pretty context ghcideCompletionsPluginPriority :: Natural ghcideCompletionsPluginPriority = defaultPluginPriority @@ -72,7 +79,7 @@ ghcideCompletionsPluginPriority = defaultPluginPriority descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginRules = produceCompletions recorder - , pluginHandlers = mkPluginHandler SMethod_TextDocumentCompletion getCompletionsLSP + , pluginHandlers = mkPluginHandler SMethod_TextDocumentCompletion (getCompletionsLSP recorder) <> mkResolveHandler SMethod_CompletionItemResolve resolveCompletion , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} , pluginPriority = ghcideCompletionsPluginPriority @@ -161,8 +168,8 @@ resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} ur (_,res) -> res -- | Generate code actions. -getCompletionsLSP :: PluginMethodHandler IdeState Method_TextDocumentCompletion -getCompletionsLSP ide plId +getCompletionsLSP :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCompletion +getCompletionsLSP recorder ide plId CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position ,_context=completionContext} = ExceptT $ do @@ -209,9 +216,11 @@ getCompletionsLSP ide plId (_, _) -> do let clientCaps = clientCapabilities $ shakeExtras ide plugins = idePlugins $ shakeExtras ide + context = deduceContext ctxTree (cursorPos pfix) config <- liftIO $ runAction "" ide $ getCompletionsConfig plId - let allCompletions = getCompletions plugins ideOpts cci' ctxTree astres bindMap pfix clientCaps config moduleExports uri + let allCompletions = getCompletions plugins ideOpts cci' context astres bindMap pfix clientCaps config moduleExports uri + logWith recorder Debug $ LogDetectedContext context 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 index 4dc41cfa2d..7919708a7d 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -39,6 +39,18 @@ data Context DefaultContext deriving (Show, Eq) +instance Pretty Context where + pretty = \case + TypeContext -> "type context" + ValueContext -> "value context" + ModuleContext mod -> "module context " <> pretty mod + ImportContext mod -> "import context " <> pretty mod + ImportListContext mod -> "import explicit context " <> pretty mod + ImportHidingContext mod -> "import hiding context " <> pretty mod + ExportContext -> "export context" + TopContext -> "top context" + DefaultContext -> "unknown context" + data GetContextTree = GetContextTree deriving (Eq, Show, Generic) instance Hashable GetContextTree diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 6fa8798d59..423dfe4f83 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -9,6 +9,7 @@ module Development.IDE.Plugin.Completions.Logic ( , cacheDataProducer , localCompletionsForParsedModule , getCompletions +, deduceContext , fromIdentInfo , getCompletionPrefix , getCompletionPrefixFromRope @@ -451,7 +452,7 @@ getCompletions :: IdePlugins a -> IdeOptions -> CachedCompletions - -> Maybe (ContextTree, PositionMapping) + -> Context -> Maybe (HieAstResult, PositionMapping) -> (Bindings, PositionMapping) -> PosPrefixInfo @@ -464,7 +465,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} - maybe_ctx + context maybe_ast_res (localBindings, bmapping) prefixInfo@(PosPrefixInfo { fullLine, prefixScope, prefixText }) @@ -474,15 +475,15 @@ getCompletions uri -- ------------------------------------------------------------------------ -- IMPORT MODULENAME (NAM|) - | ImportListContext moduleName <- maybeContext + | ImportListContext moduleName <- context = moduleImportListCompletions moduleName - | ImportHidingContext moduleName <- maybeContext + | ImportHidingContext moduleName <- context = moduleImportListCompletions moduleName -- ------------------------------------------------------------------------ -- IMPORT MODULENAM| - | ImportContext _ <- maybeContext + | ImportContext _ <- context = filtImportCompls -- ------------------------------------------------------------------------ @@ -493,8 +494,8 @@ getCompletions = [] -- ------------------------------------------------------------------------ - | TopContext <- maybeContext - = filtTopContextCompls + | TopContext <- context + = fmap (fmap (toggleSnippets caps config)) filtTopContextCompls -- ------------------------------------------------------------------------ | otherwise = @@ -534,15 +535,6 @@ getCompletions $ (if T.null enteredQual then id else mapMaybe (T.stripPrefix enteredQual)) allModNamesAsNS - -- If we have a context tree, use it to determine which completion to show. - maybeContext :: Context - maybeContext = case maybe_ctx of - Nothing -> DefaultContext - Just (ct, pmapping) -> - let PositionMapping pDelta = pmapping - position' = fromDelta pDelta pos - in Context.getContext ct position' - filtCompls :: [Scored (Bool, CompItem)] filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls (label . snd) where @@ -583,7 +575,7 @@ getCompletions }) -- completions specific to the current context - ctxCompls' = case maybeContext of + ctxCompls' = case context of TypeContext -> filter (isTypeCompl . snd) compls ValueContext -> filter (not . isTypeCompl . snd) compls DefaultContext -> compls @@ -661,6 +653,15 @@ getCompletions let isLocal = maybe False (":" `T.isPrefixOf`) _detail (Down isQual, Down score, Down isLocal, _label, _detail) +-- If we have a context tree, use it to determine which completion to show. +deduceContext :: Maybe (ContextTree, PositionMapping) -> Position -> Context +deduceContext maybeCtx pos = case maybeCtx of + Nothing -> DefaultContext + Just (ct, pmapping) -> + let PositionMapping pDelta = pmapping + position' = fromDelta pDelta pos + in Context.getContext ct position' + uniqueCompl :: CompItem -> CompItem -> Ordering uniqueCompl candidate unique = case compare (label candidate, compKind candidate) From 4b8255b142496d1b08c65dbfedef87dd96570100 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Mon, 20 Apr 2026 20:08:56 +0200 Subject: [PATCH 05/21] Add contextfull completion tests --- ghcide-test/exe/CompletionTests.hs | 94 ++++++++++++++++++++++++++++++ 1 file changed, 94 insertions(+) diff --git a/ghcide-test/exe/CompletionTests.hs b/ghcide-test/exe/CompletionTests.hs index 8c44173bd6..8e813fa22e 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,99 @@ projectCompletionTests = item ^. L.label @?= "anidentifier" ] +contextCompletionTests :: [TestTree] +contextCompletionTests = + [ testSessionSingleFile "import snippets at top level" "A.hs" + (T.unlines ["module A where", "imp"]) $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 1 3) + let importSnippets = [ c | c@CompletionItem{..} <- compls + , _kind == Just CompletionItemKind_Snippet + , _label == "import" ] + liftIO $ length importSnippets @?= 4 + + , completionTest + "function snippet at top level" + [ "module A where" + , "foo = ()" + , "fun" + ] + (Position 2 3) + [("function", CompletionItemKind_Snippet, + "${1:identifier} :: ${2:type}\n${1:identifier} = ${3:body}", + False, False, Nothing)] + + , completionTest + "class snippet at top level" + [ "module A where" + , "foo = ()" + , "cla" + ] + (Position 2 3) + [("class", CompletionItemKind_Snippet, "class ${1:name} where", + False, False, Nothing)] + + , completionTest + "instance snippet at top level" + ["module A where", "foo = ()", "inst"] + (Position 2 4) + [("instance", CompletionItemKind_Snippet, "instance ${1:name} where", + False, False, Nothing)] + + , testSessionSingleFile "no snippets in value binding" "A.hs" + (T.unlines ["module A where", "foo = imp"]) $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 1 9) + let snippets = [ c | c@CompletionItem{..} <- compls + , _kind == Just CompletionItemKind_Snippet + , _label == "import" ] + liftIO $ snippets @?= [] + + , testSessionSingleFile "no snippets in instance body" "A.hs" + (T.unlines + [ "module A where" + , "class Foo a where" + , " bar :: a -> ()" + , "instance Foo Int where" + , " bar _ = imp" + ]) $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 4 13) + let snippets = [ c | c@CompletionItem{..} <- compls + , _kind == Just CompletionItemKind_Snippet + , _label == "import" ] + liftIO $ snippets @?= [] + + , testSessionSingleFile "top level excludes regular completions" "A.hs" + (T.unlines ["module A where", "hea"]) $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 1 3) + let headCompls = [ c | c@CompletionItem{..} <- compls, _label == "head" ] + liftIO $ headCompls @?= [] + + , testSessionSingleFile "unmatched prefix at top level returns empty" "A.hs" + (T.unlines ["module A where", "xyz"]) $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 1 3) + liftIO $ compls @?= [] + + , 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)] + ] + completionDocTests :: [TestTree] completionDocTests = [ testSessionEmpty "local define" $ do From 2b15931a3567eaf186556ed35ea6164ca55cad59 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Mon, 20 Apr 2026 20:09:14 +0200 Subject: [PATCH 06/21] Remove hlint partial warnings in completion tests --- ghcide-test/exe/CompletionTests.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/ghcide-test/exe/CompletionTests.hs b/ghcide-test/exe/CompletionTests.hs index 8e813fa22e..b3cc4f2f4e 100644 --- a/ghcide-test/exe/CompletionTests.hs +++ b/ghcide-test/exe/CompletionTests.hs @@ -481,9 +481,9 @@ projectCompletionTests = "import ALocal" ] compls <- getCompletions doc (Position 1 13) - let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls - liftIO $ do - item ^. L.label @?= "ALocalModule", + + forM_ (listToMaybe $ filter ((== "ALocalModule") . (^. L.label)) compls) $ + \item -> liftIO $ item ^. L.label @?= "ALocalModule", testSessionEmptyWithCradle "auto complete functions from qualified imports without alias" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do _ <- createDoc "A.hs" "haskell" $ T.unlines [ "module A (anidentifier) where", @@ -496,9 +496,8 @@ projectCompletionTests = "A." ] compls <- getCompletions doc (Position 2 2) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier", + forM_ (listToMaybe compls) $ + \item -> liftIO $ item ^. L.label @?= "anidentifier", testSessionEmptyWithCradle "auto complete functions from qualified imports with alias" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do _ <- createDoc "A.hs" "haskell" $ T.unlines @@ -512,9 +511,8 @@ projectCompletionTests = "foo = Alias." ] compls <- getCompletions doc (Position 2 12) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier" + forM_ (listToMaybe compls) $ + \item -> liftIO $ item ^. L.label @?= "anidentifier" ] contextCompletionTests :: [TestTree] From 0414d51449381ce500d81a685ad94311ea386f25 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Mon, 20 Apr 2026 20:49:18 +0200 Subject: [PATCH 07/21] Remove unused module context --- .../src/Development/IDE/Plugin/Completions.hs | 1 - .../IDE/Plugin/Completions/Context.hs | 18 +++++++----------- 2 files changed, 7 insertions(+), 12 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 84644dfe4d..81f88cea1b 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -60,7 +60,6 @@ import Development.IDE.Core.Rules (usePropertyAction) import qualified Ide.Plugin.Config as Config -import qualified Development.IDE.Plugin.Completions.Context as Context import qualified GHC.LanguageExtensions as LangExt data Log diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index 7919708a7d..bc5542b887 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -22,8 +22,6 @@ import Ide.Plugin.RangeMap (RangeMap (..), fromList') data Context = TypeContext | ValueContext - | -- | module context with module name - ModuleContext T.Text | -- | import context with module name ImportContext T.Text | -- | import list context with module name @@ -39,11 +37,15 @@ data Context DefaultContext deriving (Show, Eq) +data ContextGroup + = ModuleGroup + | ImportGroup + | DeclGroup + instance Pretty Context where pretty = \case TypeContext -> "type context" ValueContext -> "value context" - ModuleContext mod -> "module context " <> pretty mod ImportContext mod -> "import context " <> pretty mod ImportListContext mod -> "import explicit context " <> pretty mod ImportHidingContext mod -> "import hiding context " <> pretty mod @@ -77,17 +79,11 @@ instance NFData ContextTree where rnf = rwhnf getContextTree :: ParsedModule -> ContextTree getContextTree pm = ContextTree $ fromList' entries where - HsModule{hsmodName, hsmodExports, hsmodImports, hsmodDecls} = + HsModule{hsmodExports, hsmodImports, hsmodDecls} = unLoc (pm_parsed_source pm) entries :: [(Range, Context)] - entries = moduleEntry ++ exportEntry ++ importEntries ++ declEntries - - -- Module name keyword span -> ModuleContext - moduleEntry = case hsmodName of - Just (L (locA -> ss) modName) -> - maybeToList $ (, ModuleContext (T.pack $ moduleNameString modName)) <$> srcSpanToRange ss - Nothing -> [] + entries = exportEntry ++ importEntries ++ declEntries -- Export list -> ExportContext exportEntry = case hsmodExports of From 179e200d0aed74d4bc786f3a841106e3641eec19 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Mon, 20 Apr 2026 23:27:03 +0200 Subject: [PATCH 08/21] Use a lazy 2-level list instead of a spine strict tree --- .../src/Development/IDE/Plugin/Completions.hs | 6 +- .../IDE/Plugin/Completions/Context.hs | 186 ++++++++++++------ .../IDE/Plugin/Completions/Logic.hs | 4 +- 3 files changed, 129 insertions(+), 67 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 81f88cea1b..4bc1c92857 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -97,9 +97,9 @@ produceCompletions recorder = do let cdata = localCompletionsForParsedModule uri pm return ([], Just cdata) _ -> return ([], Nothing) - define (cmapWithPrio LogShake recorder) $ \GetContextTree file -> do + define (cmapWithPrio LogShake recorder) $ \GetContextMap file -> do mbPm <- useWithStale GetParsedModule file - return ([], getContextTree . fst <$> mbPm) + return ([], getContextMap . fst <$> mbPm) define (cmapWithPrio LogShake recorder) $ \NonLocalCompletions file -> do -- For non local completions we avoid depending on the parsed module, -- synthesizing a fake module with an empty body from the buffer @@ -181,7 +181,7 @@ getCompletionsLSP recorder ide plId opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide localCompls <- useWithStaleFast LocalCompletions npath nonLocalCompls <- useWithStaleFast NonLocalCompletions npath - ctxTree <- useWithStaleFast GetContextTree npath + ctxTree <- useWithStaleFast GetContextMap npath binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath knownTargets <- liftIO $ runAction "Completion" ide $ useNoFile GetKnownTargets let localModules = maybe [] (Map.keys . targetMap) knownTargets diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index bc5542b887..5176e9a23b 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -1,20 +1,26 @@ -{-# LANGUAGE TypeFamilies #-} - -module Development.IDE.Plugin.Completions.Context where +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE TypeFamilies #-} + +module Development.IDE.Plugin.Completions.Context + ( Context (..) + , ContextMap + , GetContextMap (..) + , getContext + , getContextMap + ) where import Control.DeepSeq (NFData (..), rwhnf) import Data.Hashable (Hashable) -import qualified Data.IntervalMap.FingerTree as IM -import Data.List (maximumBy) +import Data.List (maximumBy, singleton) import Data.Maybe (maybeToList) import Data.Ord (Down (..), comparing) import qualified Data.Text as T import Development.IDE import Development.IDE.Core.PositionMapping -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (getContext) import Development.IDE.GHC.Compat.Util (bagToList) import GHC.Generics (Generic) -import Ide.Plugin.RangeMap (RangeMap (..), fromList') -- | A context of a declaration in the program -- e.g. is the declaration a type declaration or a value declaration @@ -37,11 +43,6 @@ data Context DefaultContext deriving (Show, Eq) -data ContextGroup - = ModuleGroup - | ImportGroup - | DeclGroup - instance Pretty Context where pretty = \case TypeContext -> "type context" @@ -53,99 +54,160 @@ instance Pretty Context where TopContext -> "top context" DefaultContext -> "unknown context" -data GetContextTree = GetContextTree +data GetContextMap = GetContextMap deriving (Eq, Show, Generic) -instance Hashable GetContextTree -instance NFData GetContextTree -type instance RuleResult GetContextTree = ContextTree - -newtype ContextTree = ContextTree {contextTree :: RangeMap Context} +instance Hashable GetContextMap +instance NFData GetContextMap +type instance RuleResult GetContextMap = ContextMap -instance Show ContextTree where show _ = "" -instance NFData ContextTree where rnf = rwhnf - --- | Build a 'ContextTree' from a parsed module. +-- | A lazy chunked interval structure for context lookups. +-- +-- Entries within each chunk are from a contiguous group of source items +-- (imports or declarations). The spine is purposefully lazy, to avoid finding +-- what context the cursor precisely is in. +data ContextChunk = Chunk + { low :: {-# UNPACK #-} !Position + , high :: {-# UNPACK #-} !Position + , items :: [(Range, Context)] + } + +-- | Build a single 'Chunk' from a flat list of entries, or 'ChunkEnd' if empty. +singleChunk :: [(Range, Context)] -> ContextMap +singleChunk [] = ContextMap mempty +singleChunk items = ContextMap $ singleton $ Chunk + (minimum (map (_start . fst) items)) + (maximum (map (_end . fst) items)) + items + +-- | Build lazy 'ContextChunks' by processing @n@ source items at a time. +-- The spine past the first chunk is a thunk until queried. +groupedChunks :: Int -> (a -> [(Range, Context)]) -> [a] -> ContextMap +groupedChunks n f xs = ContextMap $ go xs + where + go [] = [] + go xs = + let (group, rest) = splitAt n xs + items = concatMap f group + in case items of + [] -> go rest + _ -> Chunk + { low = minimum (map (_start . fst) items) + , high = maximum (map (_end . fst) items) + , items = items + } : go rest + +newtype ContextMap = ContextMap [ContextChunk] + deriving newtype (Monoid, Semigroup) +instance Show ContextMap where show _ = "" +instance NFData ContextMap where rnf = rwhnf + +-- | Build a 'ContextMap' from a parsed module. -- -- Walks module header, exports, imports, and top-level declarations -- (one level into class bodies). Built once per file edit and cached -- as a Shake rule. --- --- TODO: Would be nice if this would be updated incrementally. Most of the time --- edits occur in unrelated parts of the module, meaning the largest proportion of --- this tree doesn't require changing. --- --- Could be done by tracking the 'dirtied' parts of a file using didChange and --- 'refreshing' and doing a lighter weight traversal across the parsed module. -getContextTree :: ParsedModule -> ContextTree -getContextTree pm = ContextTree $ fromList' entries +getContextMap :: ParsedModule -> ContextMap +getContextMap pm = + singleChunk exportEntry + <> groupedChunks 10 importEntry hsmodImports + <> groupedChunks 10 declEntry hsmodDecls where - HsModule{hsmodExports, hsmodImports, hsmodDecls} = + HsModule {hsmodExports, hsmodImports, hsmodDecls} = unLoc (pm_parsed_source pm) - entries :: [(Range, Context)] - entries = exportEntry ++ importEntries ++ declEntries - -- Export list -> ExportContext + exportEntry :: [(Range, Context)] exportEntry = case hsmodExports of Just (L (locA -> ss) _) -> - maybeToList $ (, ExportContext) <$> srcSpanToRange ss + maybeToList $ (,ExportContext) <$> srcSpanToRange ss Nothing -> [] - -- Each import declaration - importEntries = foldMap importEntry hsmodImports - importEntry :: LImportDecl GhcPs -> [(Range, Context)] importEntry (L (locA -> ss) impDecl) = let modName = T.pack $ moduleNameString $ unLoc $ ideclName impDecl - outerCtx = (, ImportContext modName) <$> srcSpanToRange ss + outerCtx = (,ImportContext modName) <$> srcSpanToRange ss innerCtx = importListEntry modName (fmap (fmap reLoc) $ ideclImportList impDecl) - in maybeToList outerCtx ++ innerCtx + in maybeToList outerCtx ++ innerCtx importListEntry :: T.Text -> Maybe (ImportListInterpretation, Located [LIE GhcPs]) -> [(Range, Context)] importListEntry modName (Just (EverythingBut, L ss _)) = - maybeToList $ (, ImportHidingContext modName) <$> srcSpanToRange ss + maybeToList $ (,ImportHidingContext modName) <$> srcSpanToRange ss importListEntry modName (Just (Exactly, L ss _)) = - maybeToList $ (, ImportListContext modName) <$> srcSpanToRange ss + maybeToList $ (,ImportListContext modName) <$> srcSpanToRange ss importListEntry _ _ = [] - -- Top-level declarations - declEntries = concatMap declEntry hsmodDecls - declEntry :: LHsDecl GhcPs -> [(Range, Context)] declEntry (L (locA -> ss) decl) = case srcSpanToRange ss of Nothing -> [] Just range -> case decl of SigD {} -> [(range, TypeContext)] - ValD {} -> [(range, ValueContext)] + ValD _ bind -> (range, ValueContext) : bindEntries bind TyClD _ cd@ClassDecl{} -> (range, TypeContext) : classEntries cd TyClD {} -> [(range, TypeContext)] -- DataDecl, SynDecl, FamilyDecl - InstD {} -> [(range, ValueContext)] + InstD _ instDecl -> (range, ValueContext) : instEntries instDecl DerivD {} -> [(range, TypeContext)] ForD {} -> [(range, ValueContext)] SpliceD {} -> [(range, TopContext)] _ -> [(range, DefaultContext)] -- DefD, WarningD, AnnD, RuleD, DocD, KindSigD - -- One level into class bodies: method sigs and default implementations - classEntries :: TyClDecl GhcPs -> [(Range, Context)] - classEntries ClassDecl{tcdSigs, tcdMeths} = + sigsAndBindEntries :: [LSig GhcPs] -> LHsBinds GhcPs -> [(Range, Context)] + sigsAndBindEntries sigs binds = [ (r, TypeContext) - | L (locA -> ss) _ <- tcdSigs + | L (locA -> ss) _ <- sigs , Just r <- [srcSpanToRange ss] ] ++ - [ (r, ValueContext) - | L (locA -> ss) _ <- bagToList tcdMeths + [ entry + | L (locA -> ss) bind <- bagToList binds , Just r <- [srcSpanToRange ss] + , entry <- (r, ValueContext) : bindEntries bind ] + + classEntries :: TyClDecl GhcPs -> [(Range, Context)] + classEntries ClassDecl { tcdSigs, tcdMeths } = sigsAndBindEntries tcdSigs tcdMeths classEntries _ = [] + instEntries :: InstDecl GhcPs -> [(Range, Context)] + instEntries ClsInstD { cid_inst = ClsInstDecl { cid_sigs, cid_binds } } = + sigsAndBindEntries cid_sigs cid_binds + instEntries _ = [] + + bindEntries :: HsBind GhcPs -> [(Range, Context)] + bindEntries FunBind { fun_matches = MG { mg_alts = L _ alts } } = + concatMap matchLocalEntries alts + bindEntries PatBind { pat_rhs = GRHSs { grhssLocalBinds } } = + localBindEntries grhssLocalBinds + bindEntries _ = [] + + matchLocalEntries :: LMatch GhcPs (LHsExpr GhcPs) -> [(Range, Context)] + matchLocalEntries (L _ Match { m_grhss = GRHSs { grhssLocalBinds } }) = + localBindEntries grhssLocalBinds + + localBindEntries :: HsLocalBinds GhcPs -> [(Range, Context)] + localBindEntries (HsValBinds _ (ValBinds _ binds sigs)) = + sigsAndBindEntries sigs binds + localBindEntries _ = [] + -- | Look up the completion context at a given position. -- Returns the innermost (most specific) context that contains the position. -getContext :: ContextTree -> PositionResult Position -> Context -getContext (ContextTree (RangeMap im)) pos = - case IM.dominators pointInterval im of - [] -> TopContext - xs -> snd $ maximumBy (comparing (\(iv, _) -> (IM.low iv, Down (IM.high iv)))) xs +-- +-- Only the 'ContextChunks' up to and including the chunk containing the +-- query position are forced; later chunks remain as unevaluated thunks. +getContext :: ContextMap -> PositionResult Position -> Context +getContext (ContextMap chunks) pos = + case searchChunks chunks of + [] -> TopContext + xs -> snd $ maximumBy (comparing (\(Range s e, _) -> (s, Down e))) xs where - pointInterval = case pos of - PositionExact p -> IM.Interval p p - PositionRange l u -> IM.Interval l u + (qLo, qHi) = case pos of + PositionExact p -> (p, p) + PositionRange l u -> (l, u) + + dominates :: (Range, Context) -> Bool + dominates (Range s e, _) = s <= qLo && qHi <= e + + searchChunks :: [ContextChunk] -> [(Range, Context)] + searchChunks [] = [] + searchChunks (Chunk cLo cHi items : rest) + | qLo > cHi = searchChunks rest -- query is past this chunk + | qHi < cLo = [] -- query is before this chunk; stop (source order) + | otherwise = filter dominates items ++ searchChunks rest diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 423dfe4f83..dcbeb77a30 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -47,7 +47,7 @@ import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Context (Context (..), - ContextTree) + ContextMap) import qualified Development.IDE.Plugin.Completions.Context as Context import Development.IDE.Plugin.Completions.Snippet import Development.IDE.Plugin.Completions.Types @@ -654,7 +654,7 @@ getCompletions (Down isQual, Down score, Down isLocal, _label, _detail) -- If we have a context tree, use it to determine which completion to show. -deduceContext :: Maybe (ContextTree, PositionMapping) -> Position -> Context +deduceContext :: Maybe (ContextMap, PositionMapping) -> Position -> Context deduceContext maybeCtx pos = case maybeCtx of Nothing -> DefaultContext Just (ct, pmapping) -> From 6c9049d3971e7c34a3aef5aba14ba3db3302e276 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 21 Apr 2026 02:30:44 +0200 Subject: [PATCH 09/21] Avoid emitting top-level snippets when inappropriate --- .../IDE/Plugin/Completions/Context.hs | 114 ++++++++++-------- .../IDE/Plugin/Completions/Logic.hs | 11 +- .../IDE/Plugin/Completions/Snippet.hs | 46 ++++--- 3 files changed, 101 insertions(+), 70 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index 5176e9a23b..bbb67652b0 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -4,6 +4,7 @@ module Development.IDE.Plugin.Completions.Context ( Context (..) + , ContextGroup (..) , ContextMap , GetContextMap (..) , getContext @@ -11,9 +12,11 @@ module Development.IDE.Plugin.Completions.Context ) where import Control.DeepSeq (NFData (..), rwhnf) +import Control.Monad (join) import Data.Hashable (Hashable) import Data.List (maximumBy, singleton) -import Data.Maybe (maybeToList) +import Data.Maybe (catMaybes, mapMaybe, + maybeToList) import Data.Ord (Down (..), comparing) import qualified Data.Text as T import Development.IDE @@ -21,6 +24,7 @@ import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat hiding (getContext) import Development.IDE.GHC.Compat.Util (bagToList) import GHC.Generics (Generic) +import GHC.Hs (HasLoc) -- | A context of a declaration in the program -- e.g. is the declaration a type declaration or a value declaration @@ -28,21 +32,28 @@ import GHC.Generics (Generic) data Context = TypeContext | ValueContext - | -- | import context with module name + | -- | import context with module name. ImportContext T.Text - | -- | import list context with module name + | -- | import list context with module name. ImportListContext T.Text - | -- | import hiding context with module name + | -- | import hiding context with module name. ImportHidingContext T.Text - | -- | List of exported identifiers from the current module + | -- | List of exported identifiers from the current module. ExportContext - | -- | Top-level context - TopContext + | -- | Top-level context, with context groups indicating what would be valid + -- in that top-level context. NB: An empty list denotes _all_ contexts + TopContext [ContextGroup] | -- | Unsupported context, a placeholder context where we give up being smart -- and show all known symbols. DefaultContext deriving (Show, Eq) +data ContextGroup + = HeaderGroup + | ImportGroup + | DeclarationGroup + deriving (Show, Eq, Ord) + instance Pretty Context where pretty = \case TypeContext -> "type context" @@ -51,9 +62,15 @@ instance Pretty Context where ImportListContext mod -> "import explicit context " <> pretty mod ImportHidingContext mod -> "import hiding context " <> pretty mod ExportContext -> "export context" - TopContext -> "top context" + TopContext cg -> "top context " <> pretty cg DefaultContext -> "unknown context" +instance Pretty ContextGroup where + pretty = \case + HeaderGroup -> "header" + ImportGroup -> "imports" + DeclarationGroup -> "declarations" + data GetContextMap = GetContextMap deriving (Eq, Show, Generic) instance Hashable GetContextMap @@ -63,37 +80,38 @@ type instance RuleResult GetContextMap = ContextMap -- | A lazy chunked interval structure for context lookups. -- -- Entries within each chunk are from a contiguous group of source items --- (imports or declarations). The spine is purposefully lazy, to avoid finding --- what context the cursor precisely is in. +-- (imports or declarations). data ContextChunk = Chunk { low :: {-# UNPACK #-} !Position , high :: {-# UNPACK #-} !Position + , group :: {-# UNPACK #-} !ContextGroup , items :: [(Range, Context)] } -- | Build a single 'Chunk' from a flat list of entries, or 'ChunkEnd' if empty. -singleChunk :: [(Range, Context)] -> ContextMap -singleChunk [] = ContextMap mempty -singleChunk items = ContextMap $ singleton $ Chunk +singleChunk :: ContextGroup -> [(Range, Context)] -> ContextMap +singleChunk _ [] = ContextMap mempty +singleChunk group items = ContextMap $ singleton $ Chunk (minimum (map (_start . fst) items)) (maximum (map (_end . fst) items)) + group items --- | Build lazy 'ContextChunks' by processing @n@ source items at a time. --- The spine past the first chunk is a thunk until queried. -groupedChunks :: Int -> (a -> [(Range, Context)]) -> [a] -> ContextMap -groupedChunks n f xs = ContextMap $ go xs +-- | Build lazy 'ContextChunk' by processing @n@ source items at a time. +groupedChunks :: Int -> ContextGroup -> (a -> Maybe Range) -> (a -> [(Range, Context)]) -> [a] -> ContextMap +groupedChunks n group getPos getRanges xs = ContextMap $ go xs where go [] = [] go xs = - let (group, rest) = splitAt n xs - items = concatMap f group + let (chunk, rest) = splitAt n xs + items = concatMap getRanges chunk in case items of [] -> go rest _ -> Chunk - { low = minimum (map (_start . fst) items) - , high = maximum (map (_end . fst) items) - , items = items + { low = minimum (mapMaybe (fmap _start . getPos) chunk) + , high = maximum (mapMaybe (fmap _end . getPos) chunk) + , group + , items } : go rest newtype ContextMap = ContextMap [ContextChunk] @@ -108,33 +126,31 @@ instance NFData ContextMap where rnf = rwhnf -- as a Shake rule. getContextMap :: ParsedModule -> ContextMap getContextMap pm = - singleChunk exportEntry - <> groupedChunks 10 importEntry hsmodImports - <> groupedChunks 10 declEntry hsmodDecls + singleChunk HeaderGroup exportEntry + <> groupedChunks 10 ImportGroup rangeOf importEntry hsmodImports + <> groupedChunks 10 DeclarationGroup rangeOf declEntry hsmodDecls where HsModule {hsmodExports, hsmodImports, hsmodDecls} = unLoc (pm_parsed_source pm) + rangeOf :: HasLoc (Anno a) => XRec GhcPs a -> Maybe Range + rangeOf (L (locA -> ss) _) = srcSpanToRange ss + fromSpan context ss = (,context) <$> rangeOf ss + -- Export list -> ExportContext exportEntry :: [(Range, Context)] - exportEntry = case hsmodExports of - Just (L (locA -> ss) _) -> - maybeToList $ (,ExportContext) <$> srcSpanToRange ss - Nothing -> [] + exportEntry = maybeToList $ join $ fmap (fromSpan ExportContext) hsmodExports importEntry :: LImportDecl GhcPs -> [(Range, Context)] - importEntry (L (locA -> ss) impDecl) = + importEntry decl@(L _ impDecl) = let modName = T.pack $ moduleNameString $ unLoc $ ideclName impDecl - outerCtx = (,ImportContext modName) <$> srcSpanToRange ss + outerCtx = fromSpan (ImportContext modName) decl innerCtx = importListEntry modName (fmap (fmap reLoc) $ ideclImportList impDecl) - in maybeToList outerCtx ++ innerCtx + in catMaybes [outerCtx, innerCtx] - importListEntry :: T.Text -> Maybe (ImportListInterpretation, Located [LIE GhcPs]) -> [(Range, Context)] - importListEntry modName (Just (EverythingBut, L ss _)) = - maybeToList $ (,ImportHidingContext modName) <$> srcSpanToRange ss - importListEntry modName (Just (Exactly, L ss _)) = - maybeToList $ (,ImportListContext modName) <$> srcSpanToRange ss - importListEntry _ _ = [] + importListEntry modName (Just (EverythingBut, imps)) = fromSpan (ImportHidingContext modName) imps + importListEntry modName (Just (Exactly, imps)) = fromSpan (ImportHidingContext modName) imps + importListEntry _ _ = Nothing declEntry :: LHsDecl GhcPs -> [(Range, Context)] declEntry (L (locA -> ss) decl) = case srcSpanToRange ss of @@ -147,7 +163,7 @@ getContextMap pm = InstD _ instDecl -> (range, ValueContext) : instEntries instDecl DerivD {} -> [(range, TypeContext)] ForD {} -> [(range, ValueContext)] - SpliceD {} -> [(range, TopContext)] + SpliceD {} -> [(range, TopContext [])] _ -> [(range, DefaultContext)] -- DefD, WarningD, AnnD, RuleD, DocD, KindSigD sigsAndBindEntries :: [LSig GhcPs] -> LHsBinds GhcPs -> [(Range, Context)] @@ -195,8 +211,9 @@ getContextMap pm = getContext :: ContextMap -> PositionResult Position -> Context getContext (ContextMap chunks) pos = case searchChunks chunks of - [] -> TopContext - xs -> snd $ maximumBy (comparing (\(Range s e, _) -> (s, Down e))) xs + ([], []) -> TopContext [] + (groups, []) -> TopContext groups + (_, xs) -> snd $ maximumBy (comparing (\(Range s e, _) -> (s, Down e))) xs where (qLo, qHi) = case pos of PositionExact p -> (p, p) @@ -205,9 +222,12 @@ getContext (ContextMap chunks) pos = dominates :: (Range, Context) -> Bool dominates (Range s e, _) = s <= qLo && qHi <= e - searchChunks :: [ContextChunk] -> [(Range, Context)] - searchChunks [] = [] - searchChunks (Chunk cLo cHi items : rest) - | qLo > cHi = searchChunks rest -- query is past this chunk - | qHi < cLo = [] -- query is before this chunk; stop (source order) - | otherwise = filter dominates items ++ searchChunks rest + searchChunks :: [ContextChunk] -> ([ContextGroup], [(Range, Context)]) + searchChunks [] = ([], []) + searchChunks (Chunk cLo cHi group items : rest) + | -- query is past this chunk + qLo > cHi = searchChunks rest + | -- query is before this chunk + qHi < cLo = ([], []) + -- this chunk is relevant, emit the group and all relevant intervals + | otherwise = ([group], filter dominates items) <> searchChunks rest diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index dcbeb77a30..f52c95d8cc 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -494,8 +494,8 @@ getCompletions = [] -- ------------------------------------------------------------------------ - | TopContext <- context - = fmap (fmap (toggleSnippets caps config)) filtTopContextCompls + | TopContext groups <- context + = fmap (fmap (toggleSnippets caps config)) (filtTopContextCompls groups) -- ------------------------------------------------------------------------ | otherwise = @@ -633,11 +633,10 @@ getCompletions | T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts) | otherwise = [] - filtTopContextCompls :: [Scored CompletionItem] - filtTopContextCompls + filtTopContextCompls :: [Context.ContextGroup] -> [Scored CompletionItem] + filtTopContextCompls groups | T.null prefixScope - = fmap (fmap mkTopSnippetCompl) $ - Fuzzy.filter chunkSize maxC fullPrefix topContextSnippets snippetLabel + = Fuzzy.filter chunkSize maxC fullPrefix (getContextSnippets groups) (view L.label) | otherwise = [] -- We use this ordering to alphabetically sort suggestions while respecting diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs b/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs index f152e2e76c..f3e308cfc5 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs @@ -1,34 +1,46 @@ -module Development.IDE.Plugin.Completions.Snippet where +module Development.IDE.Plugin.Completions.Snippet (getContextSnippets) where import Control.Lens -import Data.String (IsString) -import Data.Text (Text) +import Data.Maybe (maybeToList) +import Data.String (IsString) +import Data.Text (Text) +import Development.IDE.Plugin.Completions.Context import Development.IDE.Plugin.Completions.Types -import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types data SnippetCompletion = SnippetCompletion - { snippetLabel :: {-# UNPACK #-} !Text, - snippetDetail :: {-# UNPACK #-} !Text, + { snippetLabel :: {-# UNPACK #-} !Text + , snippetDetail :: {-# UNPACK #-} !Text -- | Might be good to use the structured snippets instead of bare text. -- This is fine for now though, none of the top-level snippet completions are -- parameterized. - snippetContents :: {-# UNPACK #-} !Text + , snippetContents :: {-# UNPACK #-} !Text } -topContextSnippets :: [SnippetCompletion] +getContextSnippets :: [ContextGroup] -> [CompletionItem] +getContextSnippets [] = concatMap (fmap mkSnippetCompletion . snd) topContextSnippets +getContextSnippets groups = concatMap (fmap mkSnippetCompletion . concat . maybeToList . (`lookup` topContextSnippets)) groups + +topContextSnippets :: [(ContextGroup, [SnippetCompletion])] topContextSnippets = - [ SnippetCompletion "import" "import module" importUnqualifiedSnippet, - SnippetCompletion "import" "import module (explicit list)" importExplicitSnippet, - SnippetCompletion "import" "import module hiding" importHidingSnippet, - SnippetCompletion "import" "import module qualified as" importQualifiedAsSnippet, - SnippetCompletion "function" "function definition" functionDefinitionSnippet, - SnippetCompletion "class" "class declaration" classDeclarationSnippet, - SnippetCompletion "instance" "instance declaration" instanceDeclarationSnippet + [ ( ImportGroup + , [ SnippetCompletion "import" "import module" importUnqualifiedSnippet + , SnippetCompletion "import" "import module (explicit list)" importExplicitSnippet + , SnippetCompletion "import" "import module hiding" importHidingSnippet + , SnippetCompletion "import" "import module qualified as" importQualifiedAsSnippet + ] + ), + ( DeclarationGroup + , [ SnippetCompletion "function" "function definition" functionDefinitionSnippet + , SnippetCompletion "instance" "instance declaration" instanceDeclarationSnippet + , SnippetCompletion "class" "class declaration" classDeclarationSnippet + ] + ) ] -mkTopSnippetCompl :: SnippetCompletion -> CompletionItem -mkTopSnippetCompl SnippetCompletion {..} = +mkSnippetCompletion :: SnippetCompletion -> CompletionItem +mkSnippetCompletion SnippetCompletion {..} = defaultCompletionItemWithLabel snippetLabel & L.kind ?~ CompletionItemKind_Snippet & L.detail ?~ snippetDetail From d3893f736e8c5866a33e6282bf9c53d4da7f165e Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 21 Apr 2026 02:46:58 +0200 Subject: [PATCH 10/21] Swap out export contexts for module header snippet --- .../IDE/Plugin/Completions/Context.hs | 46 ++++++------------- .../IDE/Plugin/Completions/Snippet.hs | 11 ++++- 2 files changed, 24 insertions(+), 33 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index bbb67652b0..5520471035 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -12,11 +12,9 @@ module Development.IDE.Plugin.Completions.Context ) where import Control.DeepSeq (NFData (..), rwhnf) -import Control.Monad (join) import Data.Hashable (Hashable) -import Data.List (maximumBy, singleton) -import Data.Maybe (catMaybes, mapMaybe, - maybeToList) +import Data.List (maximumBy) +import Data.Maybe (catMaybes, mapMaybe) import Data.Ord (Down (..), comparing) import qualified Data.Text as T import Development.IDE @@ -38,10 +36,11 @@ data Context ImportListContext T.Text | -- | import hiding context with module name. ImportHidingContext T.Text - | -- | List of exported identifiers from the current module. - ExportContext | -- | Top-level context, with context groups indicating what would be valid - -- in that top-level context. NB: An empty list denotes _all_ contexts + -- in that top-level context. + -- + -- NB: An empty list denotes _all_ contexts, this occurs in splices which + -- overlap with the top-level declaration snippets while typing. TopContext [ContextGroup] | -- | Unsupported context, a placeholder context where we give up being smart -- and show all known symbols. @@ -61,7 +60,6 @@ instance Pretty Context where ImportContext mod -> "import context " <> pretty mod ImportListContext mod -> "import explicit context " <> pretty mod ImportHidingContext mod -> "import hiding context " <> pretty mod - ExportContext -> "export context" TopContext cg -> "top context " <> pretty cg DefaultContext -> "unknown context" @@ -88,15 +86,6 @@ data ContextChunk = Chunk , items :: [(Range, Context)] } --- | Build a single 'Chunk' from a flat list of entries, or 'ChunkEnd' if empty. -singleChunk :: ContextGroup -> [(Range, Context)] -> ContextMap -singleChunk _ [] = ContextMap mempty -singleChunk group items = ContextMap $ singleton $ Chunk - (minimum (map (_start . fst) items)) - (maximum (map (_end . fst) items)) - group - items - -- | Build lazy 'ContextChunk' by processing @n@ source items at a time. groupedChunks :: Int -> ContextGroup -> (a -> Maybe Range) -> (a -> [(Range, Context)]) -> [a] -> ContextMap groupedChunks n group getPos getRanges xs = ContextMap $ go xs @@ -126,21 +115,16 @@ instance NFData ContextMap where rnf = rwhnf -- as a Shake rule. getContextMap :: ParsedModule -> ContextMap getContextMap pm = - singleChunk HeaderGroup exportEntry - <> groupedChunks 10 ImportGroup rangeOf importEntry hsmodImports + groupedChunks 10 ImportGroup rangeOf importEntry hsmodImports <> groupedChunks 10 DeclarationGroup rangeOf declEntry hsmodDecls where - HsModule {hsmodExports, hsmodImports, hsmodDecls} = + HsModule {hsmodImports, hsmodDecls} = unLoc (pm_parsed_source pm) rangeOf :: HasLoc (Anno a) => XRec GhcPs a -> Maybe Range rangeOf (L (locA -> ss) _) = srcSpanToRange ss fromSpan context ss = (,context) <$> rangeOf ss - -- Export list -> ExportContext - exportEntry :: [(Range, Context)] - exportEntry = maybeToList $ join $ fmap (fromSpan ExportContext) hsmodExports - importEntry :: LImportDecl GhcPs -> [(Range, Context)] importEntry decl@(L _ impDecl) = let modName = T.pack $ moduleNameString $ unLoc $ ideclName impDecl @@ -210,7 +194,7 @@ getContextMap pm = -- query position are forced; later chunks remain as unevaluated thunks. getContext :: ContextMap -> PositionResult Position -> Context getContext (ContextMap chunks) pos = - case searchChunks chunks of + case searchChunks True chunks of ([], []) -> TopContext [] (groups, []) -> TopContext groups (_, xs) -> snd $ maximumBy (comparing (\(Range s e, _) -> (s, Down e))) xs @@ -222,12 +206,12 @@ getContext (ContextMap chunks) pos = dominates :: (Range, Context) -> Bool dominates (Range s e, _) = s <= qLo && qHi <= e - searchChunks :: [ContextChunk] -> ([ContextGroup], [(Range, Context)]) - searchChunks [] = ([], []) - searchChunks (Chunk cLo cHi group items : rest) + searchChunks :: Bool -> [ContextChunk] -> ([ContextGroup], [(Range, Context)]) + searchChunks _ [] = ([], []) + searchChunks firstChunk (Chunk cLo cHi group items : rest) | -- query is past this chunk - qLo > cHi = searchChunks rest + qLo > cHi = searchChunks False rest | -- query is before this chunk - qHi < cLo = ([], []) + qHi < cLo = (if firstChunk then [HeaderGroup] else [], []) -- this chunk is relevant, emit the group and all relevant intervals - | otherwise = ([group], filter dominates items) <> searchChunks rest + | otherwise = ([group], filter dominates items) <> searchChunks False rest diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs b/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs index f3e308cfc5..730d60e27c 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs @@ -24,11 +24,15 @@ getContextSnippets groups = concatMap (fmap mkSnippetCompletion . concat . maybe topContextSnippets :: [(ContextGroup, [SnippetCompletion])] topContextSnippets = - [ ( ImportGroup + [ ( HeaderGroup + , [ SnippetCompletion "module" "module header" moduleHeaderSnippet + ] + ), + ( ImportGroup , [ SnippetCompletion "import" "import module" importUnqualifiedSnippet , SnippetCompletion "import" "import module (explicit list)" importExplicitSnippet - , SnippetCompletion "import" "import module hiding" importHidingSnippet , SnippetCompletion "import" "import module qualified as" importQualifiedAsSnippet + , SnippetCompletion "import" "import module hiding" importHidingSnippet ] ), ( DeclarationGroup @@ -47,6 +51,9 @@ mkSnippetCompletion SnippetCompletion {..} = & L.insertText ?~ snippetContents & L.insertTextFormat ?~ InsertTextFormat_Snippet +moduleHeaderSnippet :: (IsString s) => s +moduleHeaderSnippet = "module ${1:name} where" + importUnqualifiedSnippet :: (IsString s) => s importUnqualifiedSnippet = "import ${1:module}" From 7c2c4a5ac9e19828e177797b39ac7616c192e503 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 21 Apr 2026 03:19:43 +0200 Subject: [PATCH 11/21] Add tests for top-level context snippets --- ghcide-test/exe/CompletionTests.hs | 57 +++++++++++++++++++++--------- 1 file changed, 40 insertions(+), 17 deletions(-) diff --git a/ghcide-test/exe/CompletionTests.hs b/ghcide-test/exe/CompletionTests.hs index b3cc4f2f4e..fc226779ea 100644 --- a/ghcide-test/exe/CompletionTests.hs +++ b/ghcide-test/exe/CompletionTests.hs @@ -53,12 +53,12 @@ testSessionEmpty name = testWithDummyPlugin name (mkIdeTestFs [FS.directCradle [ testSessionEmptyWithCradle :: TestName -> T.Text -> Session () -> TestTree testSessionEmptyWithCradle name cradle = testWithDummyPlugin name (mkIdeTestFs [file "hie.yaml" (text cradle)]) -testSessionSingleFile :: TestName -> FilePath -> T.Text -> Session () -> TestTree -testSessionSingleFile testName fp txt session = - testWithDummyPlugin testName (mkIdeTestFs [FS.directCradle [T.pack fp] , file fp (text txt)]) session +testSessionSingleFile :: TestName -> FilePath -> [T.Text] -> Session () -> TestTree +testSessionSingleFile testName fp txts session = + testWithDummyPlugin testName (mkIdeTestFs [FS.directCradle [T.pack fp] , file fp (text (T.unlines txts))]) session completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree -completionTest name src pos expected = testSessionSingleFile name "A.hs" (T.unlines src) $ do +completionTest name src pos expected = testSessionSingleFile name "A.hs" src $ do docId <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics @@ -518,15 +518,25 @@ projectCompletionTests = contextCompletionTests :: [TestTree] contextCompletionTests = [ testSessionSingleFile "import snippets at top level" "A.hs" - (T.unlines ["module A where", "imp"]) $ do + [ "module A where" + , "imp" + ] $ do doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics compls <- getCompletions doc (Position 1 3) let importSnippets = [ c | c@CompletionItem{..} <- compls - , _kind == Just CompletionItemKind_Snippet - , _label == "import" ] + , _kind == Just CompletionItemKind_Snippet + , _label == "import" ] liftIO $ length importSnippets @?= 4 + , completionTest "no import snippet past a declaration" + [ "module A where" + , "foo = ()" + , "imp" + ] + (Position 2 3) + [] + , completionTest "function snippet at top level" [ "module A where" @@ -538,6 +548,14 @@ contextCompletionTests = "${1:identifier} :: ${2:type}\n${1:identifier} = ${3:body}", False, False, Nothing)] + , completionTest "no function snippet past an import" + [ "module A where" + , "fun" + , "import Control.Monad hiding (join)" + ] + (Position 2 3) + [] + , completionTest "class snippet at top level" [ "module A where" @@ -556,7 +574,9 @@ contextCompletionTests = False, False, Nothing)] , testSessionSingleFile "no snippets in value binding" "A.hs" - (T.unlines ["module A where", "foo = imp"]) $ do + [ "module A where" + , "foo = imp" + ] $ do doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics compls <- getCompletions doc (Position 1 9) @@ -566,13 +586,12 @@ contextCompletionTests = liftIO $ snippets @?= [] , testSessionSingleFile "no snippets in instance body" "A.hs" - (T.unlines - [ "module A where" - , "class Foo a where" - , " bar :: a -> ()" - , "instance Foo Int where" - , " bar _ = imp" - ]) $ do + [ "module A where" + , "class Foo a where" + , " bar :: a -> ()" + , "instance Foo Int where" + , " bar _ = imp" + ] $ do doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics compls <- getCompletions doc (Position 4 13) @@ -582,7 +601,9 @@ contextCompletionTests = liftIO $ snippets @?= [] , testSessionSingleFile "top level excludes regular completions" "A.hs" - (T.unlines ["module A where", "hea"]) $ do + [ "module A where" + , "hea" + ] $ do doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics compls <- getCompletions doc (Position 1 3) @@ -590,7 +611,9 @@ contextCompletionTests = liftIO $ headCompls @?= [] , testSessionSingleFile "unmatched prefix at top level returns empty" "A.hs" - (T.unlines ["module A where", "xyz"]) $ do + [ "module A where" + , "xyz" + ] $ do doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics compls <- getCompletions doc (Position 1 3) From e578d74e60b3a766931dc91d66ee1b54af724bf1 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 21 Apr 2026 04:29:15 +0200 Subject: [PATCH 12/21] Include let-bindings in context detection --- ghcide-test/exe/CompletionTests.hs | 106 +++++++++++++++++- .../IDE/Plugin/Completions/Context.hs | 21 +++- 2 files changed, 124 insertions(+), 3 deletions(-) diff --git a/ghcide-test/exe/CompletionTests.hs b/ghcide-test/exe/CompletionTests.hs index fc226779ea..cdf3a586ad 100644 --- a/ghcide-test/exe/CompletionTests.hs +++ b/ghcide-test/exe/CompletionTests.hs @@ -8,7 +8,7 @@ module CompletionTests (tests) where import Config -import Control.Lens ((^.)) +import Control.Lens (view, (^.)) import qualified Control.Lens as Lens import Control.Monad import Control.Monad.IO.Class (liftIO) @@ -629,6 +629,110 @@ contextCompletionTests = ] (Position 4 8) [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)] + + -- where-clause / local binding context tests + + , 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" + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + , "data Xxxtype = 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 (view L.label) compls + liftIO $ assertBool "xxxval should appear in value context" ("xxxval" `elem` labels) + liftIO $ assertBool "Xxxtype should not appear in value context" + (not ("Xxxtype" `elem` labels)) + + , testSessionSingleFile "no snippets in where-clause" "A.hs" + [ "module A where" + , "foo x = bar" + , " where" + , " helper = imp" + ] $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 15) -- after "imp" in " helper = imp" + let snippets = [ c | c@CompletionItem{..} <- compls + , _kind == Just CompletionItemKind_Snippet + , _label == "import" ] + liftIO $ snippets @?= [] + + , 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 19) -- after "Xxx" in " sig :: Xxx" + [("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)] ] completionDocTests :: [TestTree] diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index 5520471035..76bab755ce 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NoFieldSelectors #-} {-# LANGUAGE TypeFamilies #-} @@ -174,19 +175,35 @@ getContextMap pm = bindEntries :: HsBind GhcPs -> [(Range, Context)] bindEntries FunBind { fun_matches = MG { mg_alts = L _ alts } } = concatMap matchLocalEntries alts - bindEntries PatBind { pat_rhs = GRHSs { grhssLocalBinds } } = + bindEntries PatBind { pat_rhs = GRHSs { grhssLocalBinds, grhssGRHSs } } = localBindEntries grhssLocalBinds + ++ concatMap exprLocalEntries [ body | L _ (GRHS _ _ body) <- grhssGRHSs ] bindEntries _ = [] matchLocalEntries :: LMatch GhcPs (LHsExpr GhcPs) -> [(Range, Context)] - matchLocalEntries (L _ Match { m_grhss = GRHSs { grhssLocalBinds } }) = + matchLocalEntries (L _ Match { m_grhss = GRHSs { grhssLocalBinds, grhssGRHSs } }) = localBindEntries grhssLocalBinds + ++ concatMap exprLocalEntries [ body | L _ (GRHS _ _ body) <- grhssGRHSs ] localBindEntries :: HsLocalBinds GhcPs -> [(Range, Context)] localBindEntries (HsValBinds _ (ValBinds _ binds sigs)) = sigsAndBindEntries sigs binds localBindEntries _ = [] + exprLocalEntries :: LHsExpr GhcPs -> [(Range, Context)] + exprLocalEntries (L _ expr) = case expr of +#if !MIN_VERSION_ghc(9,9,0) + HsLet _ _ binds _ body -> localBindEntries binds ++ exprLocalEntries body +#else + HsLet _ binds body -> localBindEntries binds ++ exprLocalEntries body +#endif + HsDo _ _ stmts -> + [ entry + | L _ (LetStmt _ lbs) <- unLoc stmts + , entry <- localBindEntries lbs + ] + _ -> [] + -- | Look up the completion context at a given position. -- Returns the innermost (most specific) context that contains the position. -- From c0f19c8ea759025cf2c3bcf60981957b33d02e2f Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 21 Apr 2026 21:35:22 +0200 Subject: [PATCH 13/21] Use syb in Context chunks --- ghcide-test/exe/CompletionTests.hs | 2 +- .../IDE/Plugin/Completions/Context.hs | 212 +++++++++--------- 2 files changed, 101 insertions(+), 113 deletions(-) diff --git a/ghcide-test/exe/CompletionTests.hs b/ghcide-test/exe/CompletionTests.hs index cdf3a586ad..32d1d5c6cc 100644 --- a/ghcide-test/exe/CompletionTests.hs +++ b/ghcide-test/exe/CompletionTests.hs @@ -690,7 +690,7 @@ contextCompletionTests = , " sig :: Xxx" , " sig = undefined" ] - (Position 8 19) -- after "Xxx" in " sig :: Xxx" + (Position 8 18) [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)] , completionTest diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index 76bab755ce..fee8bdb2cd 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -13,15 +13,14 @@ module Development.IDE.Plugin.Completions.Context ) where import Control.DeepSeq (NFData (..), rwhnf) +import Data.Generics (extQ, mkQ) +import Data.Generics.Schemes (everythingBut) import Data.Hashable (Hashable) -import Data.List (maximumBy) -import Data.Maybe (catMaybes, mapMaybe) -import Data.Ord (Down (..), comparing) +import Data.Maybe (mapMaybe) import qualified Data.Text as T import Development.IDE import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat hiding (getContext) -import Development.IDE.GHC.Compat.Util (bagToList) import GHC.Generics (Generic) import GHC.Hs (HasLoc) @@ -76,34 +75,46 @@ instance Hashable GetContextMap instance NFData GetContextMap type instance RuleResult GetContextMap = ContextMap --- | A lazy chunked interval structure for context lookups. --- --- Entries within each chunk are from a contiguous group of source items +-- | Entries within each chunk are from a contiguous group of source items -- (imports or declarations). data ContextChunk = Chunk - { low :: {-# UNPACK #-} !Position - , high :: {-# UNPACK #-} !Position - , group :: {-# UNPACK #-} !ContextGroup - , items :: [(Range, Context)] + { low :: {-# UNPACK #-} !Position + , high :: {-# UNPACK #-} !Position + , group :: {-# UNPACK #-} !ContextGroup + , context :: Range -> ContextResult } -- | Build lazy 'ContextChunk' by processing @n@ source items at a time. -groupedChunks :: Int -> ContextGroup -> (a -> Maybe Range) -> (a -> [(Range, Context)]) -> [a] -> ContextMap -groupedChunks n group getPos getRanges xs = ContextMap $ go xs +groupedChunks :: Int -> ContextGroup -> (a -> Maybe Range) -> (a -> Range -> ContextResult) -> [a] -> ContextMap +groupedChunks n group getPos locate xs = ContextMap $ go xs where go [] = [] go xs = let (chunk, rest) = splitAt n xs - items = concatMap getRanges chunk - in case items of + context = foldMap locate chunk + in case chunk of [] -> go rest _ -> Chunk { low = minimum (mapMaybe (fmap _start . getPos) chunk) , high = maximum (mapMaybe (fmap _end . getPos) chunk) , group - , items + , context } : go rest +data ContextResult + = NoContext + | ContextResult Range Context + +instance Semigroup ContextResult where + NoContext <> b = b + a <> NoContext = a + ar@(ContextResult a _) <> br@(ContextResult b _) = if a `dominates` b + then br + else ar + +instance Monoid ContextResult where + mempty = NoContext + newtype ContextMap = ContextMap [ContextChunk] deriving newtype (Monoid, Semigroup) instance Show ContextMap where show _ = "" @@ -116,93 +127,74 @@ instance NFData ContextMap where rnf = rwhnf -- as a Shake rule. getContextMap :: ParsedModule -> ContextMap getContextMap pm = - groupedChunks 10 ImportGroup rangeOf importEntry hsmodImports - <> groupedChunks 10 DeclarationGroup rangeOf declEntry hsmodDecls + groupedChunks 10 ImportGroup rangeOf getImportContext hsmodImports + <> groupedChunks 5 DeclarationGroup rangeOf getDeclContext hsmodDecls where HsModule {hsmodImports, hsmodDecls} = unLoc (pm_parsed_source pm) - rangeOf :: HasLoc (Anno a) => XRec GhcPs a -> Maybe Range - rangeOf (L (locA -> ss) _) = srcSpanToRange ss - fromSpan context ss = (,context) <$> rangeOf ss - - importEntry :: LImportDecl GhcPs -> [(Range, Context)] - importEntry decl@(L _ impDecl) = - let modName = T.pack $ moduleNameString $ unLoc $ ideclName impDecl - outerCtx = fromSpan (ImportContext modName) decl - innerCtx = importListEntry modName (fmap (fmap reLoc) $ ideclImportList impDecl) - in catMaybes [outerCtx, innerCtx] - - importListEntry modName (Just (EverythingBut, imps)) = fromSpan (ImportHidingContext modName) imps - importListEntry modName (Just (Exactly, imps)) = fromSpan (ImportHidingContext modName) imps - importListEntry _ _ = Nothing - - declEntry :: LHsDecl GhcPs -> [(Range, Context)] - declEntry (L (locA -> ss) decl) = case srcSpanToRange ss of - Nothing -> [] - Just range -> case decl of - SigD {} -> [(range, TypeContext)] - ValD _ bind -> (range, ValueContext) : bindEntries bind - TyClD _ cd@ClassDecl{} -> (range, TypeContext) : classEntries cd - TyClD {} -> [(range, TypeContext)] -- DataDecl, SynDecl, FamilyDecl - InstD _ instDecl -> (range, ValueContext) : instEntries instDecl - DerivD {} -> [(range, TypeContext)] - ForD {} -> [(range, ValueContext)] - SpliceD {} -> [(range, TopContext [])] - _ -> [(range, DefaultContext)] -- DefD, WarningD, AnnD, RuleD, DocD, KindSigD - - sigsAndBindEntries :: [LSig GhcPs] -> LHsBinds GhcPs -> [(Range, Context)] - sigsAndBindEntries sigs binds = - [ (r, TypeContext) - | L (locA -> ss) _ <- sigs - , Just r <- [srcSpanToRange ss] - ] ++ - [ entry - | L (locA -> ss) bind <- bagToList binds - , Just r <- [srcSpanToRange ss] - , entry <- (r, ValueContext) : bindEntries bind - ] - - classEntries :: TyClDecl GhcPs -> [(Range, Context)] - classEntries ClassDecl { tcdSigs, tcdMeths } = sigsAndBindEntries tcdSigs tcdMeths - classEntries _ = [] - - instEntries :: InstDecl GhcPs -> [(Range, Context)] - instEntries ClsInstD { cid_inst = ClsInstDecl { cid_sigs, cid_binds } } = - sigsAndBindEntries cid_sigs cid_binds - instEntries _ = [] - - bindEntries :: HsBind GhcPs -> [(Range, Context)] - bindEntries FunBind { fun_matches = MG { mg_alts = L _ alts } } = - concatMap matchLocalEntries alts - bindEntries PatBind { pat_rhs = GRHSs { grhssLocalBinds, grhssGRHSs } } = - localBindEntries grhssLocalBinds - ++ concatMap exprLocalEntries [ body | L _ (GRHS _ _ body) <- grhssGRHSs ] - bindEntries _ = [] - - matchLocalEntries :: LMatch GhcPs (LHsExpr GhcPs) -> [(Range, Context)] - matchLocalEntries (L _ Match { m_grhss = GRHSs { grhssLocalBinds, grhssGRHSs } }) = - localBindEntries grhssLocalBinds - ++ concatMap exprLocalEntries [ body | L _ (GRHS _ _ body) <- grhssGRHSs ] - - localBindEntries :: HsLocalBinds GhcPs -> [(Range, Context)] - localBindEntries (HsValBinds _ (ValBinds _ binds sigs)) = - sigsAndBindEntries sigs binds - localBindEntries _ = [] - - exprLocalEntries :: LHsExpr GhcPs -> [(Range, Context)] - exprLocalEntries (L _ expr) = case expr of -#if !MIN_VERSION_ghc(9,9,0) - HsLet _ _ binds _ body -> localBindEntries binds ++ exprLocalEntries body -#else - HsLet _ binds body -> localBindEntries binds ++ exprLocalEntries body -#endif - HsDo _ _ stmts -> - [ entry - | L _ (LetStmt _ lbs) <- unLoc stmts - , entry <- localBindEntries lbs - ] - _ -> [] +rangeOf :: HasLoc a => a -> Maybe Range +rangeOf = srcSpanToRange . locA + +contextual :: HasLoc a => Context -> Bool -> Range -> a -> (ContextResult, Bool) +contextual context shouldStop query s = + let range = rangeOf s + in case range of + Nothing -> (mempty, True) + Just range | outside query range -> (mempty, True) + Just range -> (ContextResult range context, shouldStop) + +getImportContext :: LImportDecl GhcPs -> Range -> ContextResult +getImportContext imports query = + everythingBut + (<>) + ((mempty, False) `mkQ` importQ query) + imports + +getDeclContext :: LHsDecl GhcPs -> Range -> ContextResult +getDeclContext declarations query = + everythingBut + (<>) + ((mempty, False) `mkQ` sigQ query `extQ` bindQ query `extQ` declQ query) + declarations + +importQ :: Range -> LImportDecl GhcPs -> (ContextResult, Bool) +importQ query impDecl'@(L _ impDecl) = + let importModuleName = T.pack $ moduleNameString $ unLoc $ ideclName impDecl + inlineResults = fst $ importInline query importModuleName (ideclImportList impDecl) + importResult = fst $ contextual (ImportContext importModuleName) True query impDecl' + importInline _ _ Nothing = (mempty, False) + importInline query modName (Just (which, l)) = + case which of + EverythingBut -> contextual (ImportHidingContext modName) True query l + Exactly -> contextual (ImportListContext modName) True query l + in (inlineResults <> importResult, False) + + +declQ :: Range -> LHsDecl GhcPs -> (ContextResult, Bool) +declQ query (L (locA -> ss) decl) = case srcSpanToRange ss of + Nothing -> (mempty, True) + Just range | outside query range -> (mempty, True) + Just range -> case decl of + SigD {} -> (ContextResult range TypeContext, True) + ValD {} -> (ContextResult range ValueContext, False) + TyClD {} -> (ContextResult range TypeContext, False) -- DataDecl, SynDecl, FamilyDecl + InstD {} -> (ContextResult range ValueContext, False) + DerivD {} -> (ContextResult range TypeContext, True) + SpliceD {} -> (ContextResult range (TopContext []), True) + _ -> (ContextResult range DefaultContext, True) -- DefD, WarningD, AnnD, RuleD, DocD, KindSigD + +sigQ :: Range -> LSig GhcPs -> (ContextResult, Bool) +sigQ = contextual TypeContext True + +bindQ :: Range -> LHsBind GhcPs -> (ContextResult, Bool) +bindQ = contextual ValueContext False + +dominates :: Range -> Range -> Bool +dominates (Range s e) (Range qs qe) = s <= qs && qe <= e + +outside :: Range -> Range -> Bool +outside (Range ps pe) (Range qs qe) = pe < qs || ps > qe -- | Look up the completion context at a given position. -- Returns the innermost (most specific) context that contains the position. @@ -210,25 +202,21 @@ getContextMap pm = -- Only the 'ContextChunks' up to and including the chunk containing the -- query position are forced; later chunks remain as unevaluated thunks. getContext :: ContextMap -> PositionResult Position -> Context -getContext (ContextMap chunks) pos = +getContext (ContextMap chunks) query = case searchChunks True chunks of - ([], []) -> TopContext [] - (groups, []) -> TopContext groups - (_, xs) -> snd $ maximumBy (comparing (\(Range s e, _) -> (s, Down e))) xs + (groups, NoContext) -> TopContext groups + (_, ContextResult _ found) -> found where - (qLo, qHi) = case pos of + (qLo, qHi) = case query of PositionExact p -> (p, p) PositionRange l u -> (l, u) - dominates :: (Range, Context) -> Bool - dominates (Range s e, _) = s <= qLo && qHi <= e - - searchChunks :: Bool -> [ContextChunk] -> ([ContextGroup], [(Range, Context)]) - searchChunks _ [] = ([], []) - searchChunks firstChunk (Chunk cLo cHi group items : rest) + searchChunks :: Bool -> [ContextChunk] -> ([ContextGroup], ContextResult) + searchChunks _ [] = ([], mempty) + searchChunks firstChunk (Chunk cLo cHi group contextOf : rest) | -- query is past this chunk qLo > cHi = searchChunks False rest | -- query is before this chunk - qHi < cLo = (if firstChunk then [HeaderGroup] else [], []) + qHi < cLo = (if firstChunk then [HeaderGroup] else [], mempty) -- this chunk is relevant, emit the group and all relevant intervals - | otherwise = ([group], filter dominates items) <> searchChunks False rest + | otherwise = ([group], contextOf (Range qLo qHi)) <> searchChunks False rest From 1791df83d7a7748d70bc2ad3dba610e697f3e525 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Tue, 21 Apr 2026 22:13:52 +0200 Subject: [PATCH 14/21] Cleanup `Context` module a bit --- .../IDE/Plugin/Completions/Context.hs | 133 +++++++++--------- 1 file changed, 70 insertions(+), 63 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index fee8bdb2cd..02d4ed67de 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -24,9 +24,9 @@ import Development.IDE.GHC.Compat hiding (getContext) import GHC.Generics (Generic) import GHC.Hs (HasLoc) --- | 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 +-- | 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 @@ -53,22 +53,6 @@ data ContextGroup | DeclarationGroup deriving (Show, Eq, Ord) -instance Pretty Context where - pretty = \case - TypeContext -> "type context" - ValueContext -> "value context" - ImportContext mod -> "import context " <> pretty mod - ImportListContext mod -> "import explicit context " <> pretty mod - ImportHidingContext mod -> "import hiding context " <> pretty mod - TopContext cg -> "top context " <> pretty cg - DefaultContext -> "unknown context" - -instance Pretty ContextGroup where - pretty = \case - HeaderGroup -> "header" - ImportGroup -> "imports" - DeclarationGroup -> "declarations" - data GetContextMap = GetContextMap deriving (Eq, Show, Generic) instance Hashable GetContextMap @@ -101,26 +85,27 @@ groupedChunks n group getPos locate xs = ContextMap $ go xs , context } : go rest -data ContextResult - = NoContext - | ContextResult Range Context +-- | Used during context finding, combines into the tightest interval. +-- As an intuition, the primary interface is through +-- @Monoid (Position -> ContextResult)@. +data ContextResult = NoContext | ContextResult Range Context +instance Monoid ContextResult where mempty = NoContext +instance Semigroup ContextResult where (<>) = tighten -instance Semigroup ContextResult where - NoContext <> b = b - a <> NoContext = a - ar@(ContextResult a _) <> br@(ContextResult b _) = if a `dominates` b - then br - else ar - -instance Monoid ContextResult where - mempty = NoContext +tighten :: ContextResult -> ContextResult -> ContextResult +tighten NoContext b = b +tighten a NoContext = a +tighten ar@(ContextResult a _) br@(ContextResult b _) = + if a `dominates` b then br else ar newtype ContextMap = ContextMap [ContextChunk] deriving newtype (Monoid, Semigroup) instance Show ContextMap where show _ = "" instance NFData ContextMap where rnf = rwhnf --- | Build a 'ContextMap' from a parsed module. +-- * Building + +-- | Build a @ContextMap@ from a parsed module. -- -- Walks module header, exports, imports, and top-level declarations -- (one level into class bodies). Built once per file edit and cached @@ -136,14 +121,6 @@ getContextMap pm = rangeOf :: HasLoc a => a -> Maybe Range rangeOf = srcSpanToRange . locA -contextual :: HasLoc a => Context -> Bool -> Range -> a -> (ContextResult, Bool) -contextual context shouldStop query s = - let range = rangeOf s - in case range of - Nothing -> (mempty, True) - Just range | outside query range -> (mempty, True) - Just range -> (ContextResult range context, shouldStop) - getImportContext :: LImportDecl GhcPs -> Range -> ContextResult getImportContext imports query = everythingBut @@ -158,6 +135,35 @@ getDeclContext declarations query = ((mempty, False) `mkQ` sigQ query `extQ` bindQ query `extQ` declQ query) declarations +-- * Querying + +-- | Look up the completion context at a given position. +-- Returns the innermost (most specific) context that contains the position. +-- +-- Only the 'ContextChunks' up to and including the chunk containing the +-- query position are forced; later chunks remain as unevaluated thunks. +getContext :: ContextMap -> PositionResult Position -> Context +getContext (ContextMap chunks) query = + case searchChunks True chunks of + (groups, NoContext) -> TopContext groups + (_, ContextResult _ found) -> found + where + (qLo, qHi) = case query of + PositionExact p -> (p, p) + PositionRange l u -> (l, u) + + searchChunks :: Bool -> [ContextChunk] -> ([ContextGroup], ContextResult) + searchChunks _ [] = ([], mempty) + searchChunks firstChunk (Chunk cLo cHi group contextOf : rest) + | -- query is past this chunk + qLo > cHi = searchChunks False rest + | -- query is before this chunk + qHi < cLo = (if firstChunk then [HeaderGroup] else [], mempty) + -- this chunk is relevant, emit the group and all relevant intervals + | otherwise = ([group], contextOf (Range qLo qHi)) <> searchChunks False rest + +-- * SYB queries types + importQ :: Range -> LImportDecl GhcPs -> (ContextResult, Bool) importQ query impDecl'@(L _ impDecl) = let importModuleName = T.pack $ moduleNameString $ unLoc $ ideclName impDecl @@ -190,33 +196,34 @@ sigQ = contextual TypeContext True bindQ :: Range -> LHsBind GhcPs -> (ContextResult, Bool) bindQ = contextual ValueContext False +contextual :: HasLoc a => Context -> Bool -> Range -> a -> (ContextResult, Bool) +contextual context shouldStop query s = + let range = rangeOf s + in case range of + Nothing -> (mempty, True) + Just range | outside query range -> (mempty, True) + Just range -> (ContextResult range context, shouldStop) + +-- * Helpers + dominates :: Range -> Range -> Bool dominates (Range s e) (Range qs qe) = s <= qs && qe <= e outside :: Range -> Range -> Bool outside (Range ps pe) (Range qs qe) = pe < qs || ps > qe --- | Look up the completion context at a given position. --- Returns the innermost (most specific) context that contains the position. --- --- Only the 'ContextChunks' up to and including the chunk containing the --- query position are forced; later chunks remain as unevaluated thunks. -getContext :: ContextMap -> PositionResult Position -> Context -getContext (ContextMap chunks) query = - case searchChunks True chunks of - (groups, NoContext) -> TopContext groups - (_, ContextResult _ found) -> found - where - (qLo, qHi) = case query of - PositionExact p -> (p, p) - PositionRange l u -> (l, u) +instance Pretty Context where + pretty = \case + TypeContext -> "type context" + ValueContext -> "value context" + ImportContext mod -> "import context " <> pretty mod + ImportListContext mod -> "import explicit context " <> pretty mod + ImportHidingContext mod -> "import hiding context " <> pretty mod + TopContext cg -> "top context " <> pretty cg + DefaultContext -> "unknown context" - searchChunks :: Bool -> [ContextChunk] -> ([ContextGroup], ContextResult) - searchChunks _ [] = ([], mempty) - searchChunks firstChunk (Chunk cLo cHi group contextOf : rest) - | -- query is past this chunk - qLo > cHi = searchChunks False rest - | -- query is before this chunk - qHi < cLo = (if firstChunk then [HeaderGroup] else [], mempty) - -- this chunk is relevant, emit the group and all relevant intervals - | otherwise = ([group], contextOf (Range qLo qHi)) <> searchChunks False rest +instance Pretty ContextGroup where + pretty = \case + HeaderGroup -> "header" + ImportGroup -> "imports" + DeclarationGroup -> "declarations" From 4e904c86b76cddb9ed8c019618743d445330a99a Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Thu, 23 Apr 2026 19:17:36 +0200 Subject: [PATCH 15/21] Only compare line numbers when checking cursor presence --- ghcide-test/exe/CompletionTests.hs | 19 +++++++++---------- .../IDE/Plugin/Completions/Context.hs | 12 +++++++++--- 2 files changed, 18 insertions(+), 13 deletions(-) diff --git a/ghcide-test/exe/CompletionTests.hs b/ghcide-test/exe/CompletionTests.hs index 32d1d5c6cc..43798d724c 100644 --- a/ghcide-test/exe/CompletionTests.hs +++ b/ghcide-test/exe/CompletionTests.hs @@ -200,18 +200,17 @@ localCompletionTests = [ ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) ], testSessionEmpty "incomplete entries" $ do - let src a = "data Data = " <> a - doc <- createDoc "A.hs" "haskell" $ src "AAA" + let src a = a <> " = aaa" + doc <- createDoc "A.hs" "haskell" $ src "aaa" void $ waitForTypecheck doc - let editA rhs = - changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ src rhs] - editA "AAAA" + let editA rhs = changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ src rhs] + editA "aaaa" void $ waitForTypecheck doc - editA "AAAAA" + editA "aaaaa" void $ waitForTypecheck doc - compls <- getCompletions doc (Position 0 15) - liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"] + compls <- getCompletions doc (Position 0 11) + liftIO $ filter ("aaa" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["aaaaa"] pure (), completionTest "polymorphic record dot completion" @@ -345,10 +344,10 @@ otherCompletionTests = [ T.unlines [ "module A where", "import B", - "memb" + "3 = memb" ] _ <- waitForDiagnostics - compls <- getCompletions docA $ Position 2 4 + compls <- getCompletions docA $ Position 2 7 let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] liftIO $ take 1 compls' @?= ["member"], diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index 02d4ed67de..fddef57567 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -155,8 +155,9 @@ getContext (ContextMap chunks) query = searchChunks :: Bool -> [ContextChunk] -> ([ContextGroup], ContextResult) searchChunks _ [] = ([], mempty) searchChunks firstChunk (Chunk cLo cHi group contextOf : rest) - | -- query is past this chunk - qLo > cHi = searchChunks False rest + | -- query is past this chunk (line-only comparison so cursors + -- past the last column on the final line still match) + _line qLo > _line cHi = searchChunks False rest | -- query is before this chunk qHi < cLo = (if firstChunk then [HeaderGroup] else [], mempty) -- this chunk is relevant, emit the group and all relevant intervals @@ -209,8 +210,13 @@ contextual context shouldStop query s = dominates :: Range -> Range -> Bool dominates (Range s e) (Range qs qe) = s <= qs && qe <= e +-- | A query range is outside a source range if it ends before the source +-- starts, or it starts on a line after the source ends. +-- We intentionally compare only lines (not columns) for the trailing +-- boundary so that a cursor past the last token on a line still falls +-- inside the node occupying that line. outside :: Range -> Range -> Bool -outside (Range ps pe) (Range qs qe) = pe < qs || ps > qe +outside (Range ps pe) (Range qs qe) = pe < qs || _line ps > _line qe instance Pretty Context where pretty = \case From 90d8d2fe9e0f921bc9e1dad37d7c1c311259df5c Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Thu, 23 Apr 2026 19:17:36 +0200 Subject: [PATCH 16/21] Only compare line numbers when checking cursor presence --- ghcide-test/exe/CompletionTests.hs | 18 +++++------ plugins/hls-refactor-plugin/test/Main.hs | 40 ++++++++++++------------ 2 files changed, 29 insertions(+), 29 deletions(-) diff --git a/ghcide-test/exe/CompletionTests.hs b/ghcide-test/exe/CompletionTests.hs index 43798d724c..24f57b27a7 100644 --- a/ghcide-test/exe/CompletionTests.hs +++ b/ghcide-test/exe/CompletionTests.hs @@ -523,9 +523,7 @@ contextCompletionTests = doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics compls <- getCompletions doc (Position 1 3) - let importSnippets = [ c | c@CompletionItem{..} <- compls - , _kind == Just CompletionItemKind_Snippet - , _label == "import" ] + let importSnippets = filterSnippetsLabel "import" compls liftIO $ length importSnippets @?= 4 , completionTest "no import snippet past a declaration" @@ -594,9 +592,7 @@ contextCompletionTests = doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics compls <- getCompletions doc (Position 4 13) - let snippets = [ c | c@CompletionItem{..} <- compls - , _kind == Just CompletionItemKind_Snippet - , _label == "import" ] + let snippets = filterSnippetsLabel "import" compls liftIO $ snippets @?= [] , testSessionSingleFile "top level excludes regular completions" "A.hs" @@ -671,9 +667,7 @@ contextCompletionTests = doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics compls <- getCompletions doc (Position 3 15) -- after "imp" in " helper = imp" - let snippets = [ c | c@CompletionItem{..} <- compls - , _kind == Just CompletionItemKind_Snippet - , _label == "import" ] + let snippets = filterSnippetsLabel "import" compls liftIO $ snippets @?= [] , completionTest @@ -733,6 +727,12 @@ contextCompletionTests = (Position 5 19) -- after "Xxx" in " let helper :: Xxx" [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)] ] + where + filterSnippetsLabel l snippets = + [ c | c@CompletionItem{..} <- snippets + , _kind == Just CompletionItemKind_Snippet + , _label == l + ] completionDocTests :: [TestTree] completionDocTests = diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 8c73eab52e..5295022289 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -189,30 +189,30 @@ completionTests = , testGroup "Data constructor" [ completionCommandTest "not imported" - ["module A where", "import Text.Printf ()", "ZeroPad"] - (Position 2 4) + ["module A where", "import Text.Printf ()", "a = ZeroPad"] + (Position 2 8) "ZeroPad" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "a = ZeroPad"] , completionCommandTest "parent imported abs" - ["module A where", "import Text.Printf (FormatAdjustment)", "ZeroPad"] - (Position 2 4) + ["module A where", "import Text.Printf (FormatAdjustment)", "a = ZeroP"] + (Position 2 8) "ZeroPad" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "a = ZeroP"] , completionNoCommandTest "parent imported all" - ["module A where", "import Text.Printf (FormatAdjustment (..))", "ZeroPad"] - (Position 2 4) + ["module A where", "import Text.Printf (FormatAdjustment (..))", "a = ZeroP"] + (Position 2 8) "ZeroPad" , completionNoCommandTest "already imported" - ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"] - (Position 2 4) + ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "a = ZeroP"] + (Position 2 8) "ZeroPad" , completionNoCommandTest "function from Prelude" - ["module A where", "import Data.Maybe ()", "Nothing"] - (Position 2 4) + ["module A where", "import Data.Maybe ()", "a = Nothi"] + (Position 2 8) "Nothing" , completionCommandTest "type operator parent" @@ -224,20 +224,20 @@ completionTests = , testGroup "Record completion" [ completionCommandTest "not imported" - ["module A where", "import Text.Printf ()", "FormatParse"] - (Position 2 10) + ["module A where", "import Text.Printf ()", "a :: FormatParse"] + (Position 2 14) "FormatParse" - ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] + ["module A where", "import Text.Printf (FormatParse)", "a :: FormatParse"] , completionCommandTest "parent imported" - ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] - (Position 2 10) + ["module A where", "import Text.Printf (FormatParse)", "a = FormatParse"] + (Position 2 14) "FormatParse" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "a = FormatParse"] , completionNoCommandTest "already imported" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] - (Position 2 10) + ["module A where", "import Text.Printf (FormatParse (FormatParse))", "a = FormatP"] + (Position 2 14) "FormatParse" ] , testGroup "Package completion" From 07793065c58f3e5b0a25216495d029142e529836 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Fri, 24 Apr 2026 23:46:49 +0200 Subject: [PATCH 17/21] Compatibility ifs --- .../Development/IDE/Plugin/Completions/Context.hs | 14 ++++++++++++++ hls-plugin-api/src/Ide/PluginUtils.hs | 9 ++++----- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index fddef57567..da43090bfa 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -22,7 +22,11 @@ import Development.IDE import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat hiding (getContext) import GHC.Generics (Generic) + +#if MIN_VERSION_ghc(9,9,0) import GHC.Hs (HasLoc) +#endif + -- | 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 @@ -118,8 +122,13 @@ getContextMap pm = HsModule {hsmodImports, hsmodDecls} = unLoc (pm_parsed_source pm) +#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 getImportContext :: LImportDecl GhcPs -> Range -> ContextResult getImportContext imports query = @@ -197,7 +206,12 @@ sigQ = contextual TypeContext True bindQ :: Range -> LHsBind GhcPs -> (ContextResult, Bool) bindQ = contextual ValueContext False + +#if MIN_VERSION_ghc(9,9,0) contextual :: HasLoc a => Context -> Bool -> Range -> a -> (ContextResult, Bool) +#else +contextual :: Context -> Bool -> Range -> GenLocated (SrcSpanAnn' a) e -> (ContextResult, Bool) +#endif contextual context shouldStop query s = let range = rangeOf s in case range of diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index e34d19f8b0..24b078ec54 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -7,7 +7,7 @@ module Ide.PluginUtils extendNextLine, extendLineStart, extendToFullLines, - WithDeletions(..), + WithDeletions (..), getProcessID, makeDiffTextEdit, makeDiffTextEditAdditive, @@ -31,10 +31,12 @@ module Ide.PluginUtils rangesOverlap, positionInRange, usePropertyLsp, + -- * Escape unescape, + -- * toAbsolute - toAbsolute + toAbsolute, ) where @@ -99,7 +101,6 @@ extendLineStart (Range (Position sl _) e) = extendToFullLines :: Range -> Range extendToFullLines = extendLineStart . extendNextLine - -- --------------------------------------------------------------------- data WithDeletions = IncludeDeletions | SkipDeletions @@ -278,7 +279,6 @@ fullRange s = Range startPos endPos subRange :: Range -> Range -> Bool subRange = isSubrangeOf - -- | Check whether the two 'Range's overlap in any way. -- -- >>> rangesOverlap (mkRange 1 0 1 4) (mkRange 1 2 1 5) @@ -306,7 +306,6 @@ allLspCmdIds pid commands = concatMap go commands -- --------------------------------------------------------------------- - type TextParser = P.Parsec Void T.Text -- | Unescape printable escape sequences within double quotes. From 35ee61adc555aa9c97bd7599be004eab3bc925dd Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Sat, 25 Apr 2026 04:23:02 +0200 Subject: [PATCH 18/21] Don't output module snippets when present --- ghcide-test/exe/CompletionTests.hs | 21 +++- .../src/Development/IDE/Plugin/Completions.hs | 3 +- .../IDE/Plugin/Completions/Context.hs | 107 +++++++++++++----- .../IDE/Plugin/Completions/Logic.hs | 4 +- .../IDE/Plugin/Completions/Snippet.hs | 11 +- 5 files changed, 111 insertions(+), 35 deletions(-) diff --git a/ghcide-test/exe/CompletionTests.hs b/ghcide-test/exe/CompletionTests.hs index 24f57b27a7..c21162834a 100644 --- a/ghcide-test/exe/CompletionTests.hs +++ b/ghcide-test/exe/CompletionTests.hs @@ -625,8 +625,6 @@ contextCompletionTests = (Position 4 8) [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)] - -- where-clause / local binding context tests - , completionTest "type sig in where-clause gives type completions" [ "{-# OPTIONS_GHC -Wunused-binds #-}" @@ -726,6 +724,25 @@ contextCompletionTests = ] (Position 5 19) -- after "Xxx" in " let helper :: Xxx" [("Xxxtype", CompletionItemKind_Struct, "Xxxtype", False, True, Nothing)] + + , testSessionSingleFile "module header snippet shown when no module declaration" "A.hs" + [ "mod" + ] $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 0 3) + let moduleSnippets = filterSnippetsLabel "module" compls + liftIO $ length moduleSnippets @?= 1 + + , testSessionSingleFile "module header snippet not shown when module declaration exists" "A.hs" + [ "module A where" + , "mod" + ] $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 1 3) + let moduleSnippets = filterSnippetsLabel "module" compls + liftIO $ moduleSnippets @?= [] ] where filterSnippetsLabel l snippets = diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 4bc1c92857..adc9eb4b02 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -216,9 +216,10 @@ getCompletionsLSP recorder ide plId let clientCaps = clientCapabilities $ shakeExtras ide plugins = idePlugins $ shakeExtras ide context = deduceContext ctxTree (cursorPos pfix) + hasModuleHeader = maybe False (contextHasModuleHeader . fst) ctxTree config <- liftIO $ runAction "" ide $ getCompletionsConfig plId - let allCompletions = getCompletions plugins ideOpts cci' context astres bindMap pfix clientCaps config moduleExports uri + let allCompletions = getCompletions plugins ideOpts cci' context hasModuleHeader astres bindMap pfix clientCaps config moduleExports uri logWith recorder Debug $ LogDetectedContext context pure $ InL (orderedCompletions allCompletions) _ -> return (InL []) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index da43090bfa..41d5063870 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -8,15 +8,24 @@ module Development.IDE.Plugin.Completions.Context , ContextGroup (..) , ContextMap , GetContextMap (..) + , contextHasModuleHeader , getContext , getContextMap ) where import Control.DeepSeq (NFData (..), rwhnf) -import Data.Generics (extQ, mkQ) -import Data.Generics.Schemes (everythingBut) +import Data.Generics (Data (..), GenericQ, + extQ, mkQ) import Data.Hashable (Hashable) -import Data.Maybe (mapMaybe) +import Data.List.Extra (nubOrd) +import Data.Maybe (fromJust, isJust, + mapMaybe) +import Data.List.Extra (nubOrd) +import Data.Maybe (isJust, mapMaybe, + maybeToList) +import Data.List.Extra (nub) +import Data.Maybe (isJust, mapMaybe, + maybeToList) import qualified Data.Text as T import Development.IDE import Development.IDE.Core.PositionMapping @@ -68,31 +77,38 @@ type instance RuleResult GetContextMap = ContextMap data ContextChunk = Chunk { low :: {-# UNPACK #-} !Position , high :: {-# UNPACK #-} !Position - , group :: {-# UNPACK #-} !ContextGroup + , group :: !ContextGroup , context :: Range -> ContextResult } -- | Build lazy 'ContextChunk' by processing @n@ source items at a time. -groupedChunks :: Int -> ContextGroup -> (a -> Maybe Range) -> (a -> Range -> ContextResult) -> [a] -> ContextMap -groupedChunks n group getPos locate xs = ContextMap $ go xs +groupedChunks :: Int -> ContextGroup -> (a -> Maybe Range) -> (a -> Range -> ContextResult) -> [a] -> [ContextChunk] +groupedChunks n group getPos locate xs = go xs where go [] = [] go xs = let (chunk, rest) = splitAt n xs context = foldMap locate chunk - in case chunk of + positions = mapMaybe getPos chunk + in case positions of [] -> go rest - _ -> Chunk - { low = minimum (mapMaybe (fmap _start . getPos) chunk) - , high = maximum (mapMaybe (fmap _end . getPos) chunk) + ps -> Chunk + { low = minimum (fmap _start ps) + , high = maximum (fmap _end ps) , group , context } : go rest +-- | Build lazy 'ContextChunk' by processing @n@ source items at a time. +singletonChunk :: ContextGroup -> (a -> Maybe Range) -> (a -> Range -> ContextResult) -> a -> ContextChunk +singletonChunk group getPos locate inp = Chunk s e group (locate inp) + where + Range s e = fromJust $ getPos inp + -- | Used during context finding, combines into the tightest interval. -- As an intuition, the primary interface is through --- @Monoid (Position -> ContextResult)@. -data ContextResult = NoContext | ContextResult Range Context +-- @Monoid (Range -> ContextResult)@. +data ContextResult = NoContext | ContextResult !Range !Context instance Monoid ContextResult where mempty = NoContext instance Semigroup ContextResult where (<>) = tighten @@ -102,8 +118,14 @@ tighten a NoContext = a tighten ar@(ContextResult a _) br@(ContextResult b _) = if a `dominates` b then br else ar -newtype ContextMap = ContextMap [ContextChunk] - deriving newtype (Monoid, Semigroup) +-- | A context map, built from a parsed module. Stores whether the module +-- already has a @module ... where@ header, so that the header snippet can +-- be suppressed for files that already declare a module. +data ContextMap = ContextMap !Bool [ContextChunk] +instance Semigroup ContextMap where + ContextMap h1 c1 <> ContextMap h2 c2 = ContextMap (h1 || h2) (c1 <> c2) +instance Monoid ContextMap where + mempty = ContextMap False [] instance Show ContextMap where show _ = "" instance NFData ContextMap where rnf = rwhnf @@ -116,10 +138,14 @@ instance NFData ContextMap where rnf = rwhnf -- as a Shake rule. getContextMap :: ParsedModule -> ContextMap getContextMap pm = - groupedChunks 10 ImportGroup rangeOf getImportContext hsmodImports - <> groupedChunks 5 DeclarationGroup rangeOf getDeclContext hsmodDecls + ContextMap (isJust hsmodName) $ + -- These denote the size of the "jumps" of the cursor when traversing the AST. + -- Reduces the amount of data we have to look at with syb. + moduleChunk + <> groupedChunks 10 ImportGroup rangeOf getImportContext hsmodImports + <> groupedChunks 4 DeclarationGroup rangeOf getDeclContext hsmodDecls where - HsModule {hsmodImports, hsmodDecls} = + HsModule {hsmodName, hsmodImports, hsmodDecls} = unLoc (pm_parsed_source pm) #if MIN_VERSION_ghc(9,9,0) @@ -130,47 +156,59 @@ rangeOf :: GenLocated (SrcSpanAnn' a) e -> Maybe Range rangeOf = srcSpanToRange . getLocA #endif +getHeaderContext :: Data a => a -> Range -> ContextResult +getHeaderContext decl query = + gather + (<>) + ((mempty, False) `mkQ` modNameQ query) + decl + getImportContext :: LImportDecl GhcPs -> Range -> ContextResult getImportContext imports query = - everythingBut + gather (<>) ((mempty, False) `mkQ` importQ query) imports getDeclContext :: LHsDecl GhcPs -> Range -> ContextResult getDeclContext declarations query = - everythingBut + gather (<>) ((mempty, False) `mkQ` sigQ query `extQ` bindQ query `extQ` declQ query) declarations -- * Querying +-- | Returns 'True' when the parsed module already has a @module ... where@ +-- declaration. Used downstream to suppress the module header snippet. +contextHasModuleHeader :: ContextMap -> Bool +contextHasModuleHeader (ContextMap h _) = h + -- | Look up the completion context at a given position. -- Returns the innermost (most specific) context that contains the position. -- -- Only the 'ContextChunks' up to and including the chunk containing the -- query position are forced; later chunks remain as unevaluated thunks. getContext :: ContextMap -> PositionResult Position -> Context -getContext (ContextMap chunks) query = - case searchChunks True chunks of - (groups, NoContext) -> TopContext groups +getContext (ContextMap _ chunks) query = + case searchChunks HeaderGroup chunks mempty of + (groups, NoContext) -> TopContext $ nub groups (_, ContextResult _ found) -> found where (qLo, qHi) = case query of PositionExact p -> (p, p) PositionRange l u -> (l, u) - searchChunks :: Bool -> [ContextChunk] -> ([ContextGroup], ContextResult) - searchChunks _ [] = ([], mempty) - searchChunks firstChunk (Chunk cLo cHi group contextOf : rest) + searchChunks :: ContextGroup -> [ContextChunk] -> ([ContextGroup], ContextResult) -> ([ContextGroup], ContextResult) + searchChunks _ [] !acc = acc + searchChunks lastChunk (Chunk cLo cHi group contextOf : rest) !acc | -- query is past this chunk (line-only comparison so cursors -- past the last column on the final line still match) - _line qLo > _line cHi = searchChunks False rest + _line qLo > _line cHi = searchChunks group rest acc | -- query is before this chunk - qHi < cLo = (if firstChunk then [HeaderGroup] else [], mempty) + qHi < cLo = ([lastChunk, group], mempty) <> acc -- this chunk is relevant, emit the group and all relevant intervals - | otherwise = ([group], contextOf (Range qLo qHi)) <> searchChunks False rest + | otherwise = searchChunks group rest (([group], contextOf (Range qLo qHi)) <> acc) -- * SYB queries types @@ -200,6 +238,9 @@ declQ query (L (locA -> ss) decl) = case srcSpanToRange ss of SpliceD {} -> (ContextResult range (TopContext []), True) _ -> (ContextResult range DefaultContext, True) -- DefD, WarningD, AnnD, RuleD, DocD, KindSigD +modNameQ :: Range -> XRec GhcPs ModuleName -> (ContextResult, Bool) +modNameQ = contextual (TopContext [HeaderGroup]) True + sigQ :: Range -> LSig GhcPs -> (ContextResult, Bool) sigQ = contextual TypeContext True @@ -247,3 +288,13 @@ instance Pretty ContextGroup where HeaderGroup -> "header" ImportGroup -> "imports" DeclarationGroup -> "declarations" + +-- | Variation of @Data.Generics.Schemes.everythingBut@, but uses foldl'. +gather :: forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r +gather k f = go + where + go :: GenericQ r + go x = let (v, stop) = f x + in if stop + then v + else foldl' k 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 f52c95d8cc..b04a061864 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -453,6 +453,7 @@ getCompletions -> IdeOptions -> CachedCompletions -> Context + -> Bool -> Maybe (HieAstResult, PositionMapping) -> (Bindings, PositionMapping) -> PosPrefixInfo @@ -466,6 +467,7 @@ getCompletions ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} context + hasModuleHeader maybe_ast_res (localBindings, bmapping) prefixInfo@(PosPrefixInfo { fullLine, prefixScope, prefixText }) @@ -636,7 +638,7 @@ getCompletions filtTopContextCompls :: [Context.ContextGroup] -> [Scored CompletionItem] filtTopContextCompls groups | T.null prefixScope - = Fuzzy.filter chunkSize maxC fullPrefix (getContextSnippets groups) (view L.label) + = Fuzzy.filter chunkSize maxC fullPrefix (getContextSnippets hasModuleHeader groups) (view L.label) | otherwise = [] -- We use this ordering to alphabetically sort suggestions while respecting diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs b/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs index 730d60e27c..e639344296 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Snippet.hs @@ -18,9 +18,14 @@ data SnippetCompletion = SnippetCompletion , snippetContents :: {-# UNPACK #-} !Text } -getContextSnippets :: [ContextGroup] -> [CompletionItem] -getContextSnippets [] = concatMap (fmap mkSnippetCompletion . snd) topContextSnippets -getContextSnippets groups = concatMap (fmap mkSnippetCompletion . concat . maybeToList . (`lookup` topContextSnippets)) groups +getContextSnippets :: Bool -> [ContextGroup] -> [CompletionItem] +getContextSnippets hasModuleHeader groups = + let tbl = if hasModuleHeader + then filter ((/= HeaderGroup) . fst) topContextSnippets + else topContextSnippets + in fmap mkSnippetCompletion $ case groups of + [] -> concatMap snd tbl + _ -> concatMap (concat . maybeToList . (`lookup` tbl)) groups topContextSnippets :: [(ContextGroup, [SnippetCompletion])] topContextSnippets = From e1100c43321f74208d9903639e6cd3bcdd626f29 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Sat, 25 Apr 2026 13:42:03 +0200 Subject: [PATCH 19/21] More compatibility changes --- .../IDE/Plugin/Completions/Context.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index 41d5063870..fdb5419ee0 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -14,15 +14,10 @@ module Development.IDE.Plugin.Completions.Context ) where import Control.DeepSeq (NFData (..), rwhnf) +import Control.Monad (join) import Data.Generics (Data (..), GenericQ, extQ, mkQ) import Data.Hashable (Hashable) -import Data.List.Extra (nubOrd) -import Data.Maybe (fromJust, isJust, - mapMaybe) -import Data.List.Extra (nubOrd) -import Data.Maybe (isJust, mapMaybe, - maybeToList) import Data.List.Extra (nub) import Data.Maybe (isJust, mapMaybe, maybeToList) @@ -100,10 +95,9 @@ groupedChunks n group getPos locate xs = go xs } : go rest -- | Build lazy 'ContextChunk' by processing @n@ source items at a time. -singletonChunk :: ContextGroup -> (a -> Maybe Range) -> (a -> Range -> ContextResult) -> a -> ContextChunk -singletonChunk group getPos locate inp = Chunk s e group (locate inp) - where - Range s e = fromJust $ getPos inp +singletonChunk :: ContextGroup -> (a -> Maybe Range) -> (a -> Range -> ContextResult) -> a -> Maybe ContextChunk +singletonChunk group getPos locate inp = flip fmap (getPos inp) $ + \(Range s e) -> Chunk s e group (locate inp) -- | Used during context finding, combines into the tightest interval. -- As an intuition, the primary interface is through @@ -145,6 +139,11 @@ getContextMap pm = <> groupedChunks 10 ImportGroup rangeOf getImportContext hsmodImports <> groupedChunks 4 DeclarationGroup rangeOf getDeclContext hsmodDecls where +#if MIN_VERSION_ghc(9,9,0) + moduleChunk = maybeToList (singletonChunk HeaderGroup rangeOf getHeaderContext hsmodName) +#else + moduleChunk = maybeToList $ join $ fmap (singletonChunk HeaderGroup rangeOf getHeaderContext) hsmodName +#endif HsModule {hsmodName, hsmodImports, hsmodDecls} = unLoc (pm_parsed_source pm) From d16ea1fab0a28483c8dec9a4399a86a407e5a8e6 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Sat, 25 Apr 2026 19:41:19 +0200 Subject: [PATCH 20/21] fixup! More compatibility changes --- ghcide/src/Development/IDE/Plugin/Completions/Context.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index fdb5419ee0..ed9ea8bfc9 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -18,7 +18,7 @@ import Control.Monad (join) import Data.Generics (Data (..), GenericQ, extQ, mkQ) import Data.Hashable (Hashable) -import Data.List.Extra (nub) +import Data.List.Extra (foldl', nub) import Data.Maybe (isJust, mapMaybe, maybeToList) import qualified Data.Text as T From ae24477236357ffe2cd49efe4c268de4093c8561 Mon Sep 17 00:00:00 2001 From: Curtis Chin Jen Sem Date: Mon, 27 Apr 2026 01:06:39 +0200 Subject: [PATCH 21/21] Deduplicate range checking --- .../IDE/Plugin/Completions/Context.hs | 75 +++++++++++-------- .../IDE/Plugin/Completions/Logic.hs | 13 +--- 2 files changed, 45 insertions(+), 43 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs index ed9ea8bfc9..891a263d61 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Context.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Context.hs @@ -9,6 +9,7 @@ module Development.IDE.Plugin.Completions.Context , ContextMap , GetContextMap (..) , contextHasModuleHeader + , deduceContext , getContext , getContextMap ) where @@ -18,7 +19,8 @@ import Control.Monad (join) import Data.Generics (Data (..), GenericQ, extQ, mkQ) import Data.Hashable (Hashable) -import Data.List.Extra (foldl', nub) +import Data.List (foldl') +import Data.List.Extra (nub) import Data.Maybe (isJust, mapMaybe, maybeToList) import qualified Data.Text as T @@ -26,6 +28,7 @@ import Development.IDE import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat hiding (getContext) import GHC.Generics (Generic) +import Language.LSP.Protocol.Types (isSubrangeOf) #if MIN_VERSION_ghc(9,9,0) import GHC.Hs (HasLoc) @@ -110,7 +113,7 @@ tighten :: ContextResult -> ContextResult -> ContextResult tighten NoContext b = b tighten a NoContext = a tighten ar@(ContextResult a _) br@(ContextResult b _) = - if a `dominates` b then br else ar + if b `isSubrangeOf` a then br else ar -- | A context map, built from a parsed module. Stores whether the module -- already has a @module ... where@ header, so that the header snippet can @@ -137,7 +140,7 @@ getContextMap pm = -- Reduces the amount of data we have to look at with syb. moduleChunk <> groupedChunks 10 ImportGroup rangeOf getImportContext hsmodImports - <> groupedChunks 4 DeclarationGroup rangeOf getDeclContext hsmodDecls + <> groupedChunks 5 DeclarationGroup rangeOf getDeclContext hsmodDecls where #if MIN_VERSION_ghc(9,9,0) moduleChunk = maybeToList (singletonChunk HeaderGroup rangeOf getHeaderContext hsmodName) @@ -147,14 +150,6 @@ getContextMap pm = HsModule {hsmodName, hsmodImports, hsmodDecls} = unLoc (pm_parsed_source pm) -#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 - getHeaderContext :: Data a => a -> Range -> ContextResult getHeaderContext decl query = gather @@ -209,6 +204,16 @@ getContext (ContextMap _ chunks) query = -- this chunk is relevant, emit the group and all relevant intervals | otherwise = searchChunks group rest (([group], contextOf (Range qLo qHi)) <> acc) +-- | Look up the completion context at the given position, applying a position +-- mapping to account for stale data. +deduceContext :: Maybe (ContextMap, PositionMapping) -> Position -> Context +deduceContext maybeCtx pos = case maybeCtx of + Nothing -> DefaultContext + Just (ct, pmapping) -> + let PositionMapping pDelta = pmapping + position' = fromDelta pDelta pos + in getContext ct position' + -- * SYB queries types importQ :: Range -> LImportDecl GhcPs -> (ContextResult, Bool) @@ -221,21 +226,20 @@ importQ query impDecl'@(L _ impDecl) = case which of EverythingBut -> contextual (ImportHidingContext modName) True query l Exactly -> contextual (ImportListContext modName) True query l - in (inlineResults <> importResult, False) + in (inlineResults <> importResult, True) declQ :: Range -> LHsDecl GhcPs -> (ContextResult, Bool) -declQ query (L (locA -> ss) decl) = case srcSpanToRange ss of - Nothing -> (mempty, True) - Just range | outside query range -> (mempty, True) - Just range -> case decl of - SigD {} -> (ContextResult range TypeContext, True) - ValD {} -> (ContextResult range ValueContext, False) - TyClD {} -> (ContextResult range TypeContext, False) -- DataDecl, SynDecl, FamilyDecl - InstD {} -> (ContextResult range ValueContext, False) - DerivD {} -> (ContextResult range TypeContext, True) - SpliceD {} -> (ContextResult range (TopContext []), True) - _ -> (ContextResult range DefaultContext, True) -- DefD, WarningD, AnnD, RuleD, DocD, KindSigD +declQ query decl'@(L _ decl) = + let range = rangeOf decl' + in contInRange query range $ \declRange -> case decl of + SigD {} -> (ContextResult declRange TypeContext, True) + ValD {} -> (ContextResult declRange ValueContext, False) + TyClD {} -> (ContextResult declRange TypeContext, False) -- DataDecl, SynDecl, FamilyDecl + InstD {} -> (ContextResult declRange ValueContext, False) + DerivD {} -> (ContextResult declRange TypeContext, True) + SpliceD {} -> (ContextResult declRange (TopContext []), True) + _ -> (ContextResult declRange DefaultContext, True) -- DefD, WarningD, AnnD, RuleD, DocD, KindSigD modNameQ :: Range -> XRec GhcPs ModuleName -> (ContextResult, Bool) modNameQ = contextual (TopContext [HeaderGroup]) True @@ -246,7 +250,6 @@ sigQ = contextual TypeContext True bindQ :: Range -> LHsBind GhcPs -> (ContextResult, Bool) bindQ = contextual ValueContext False - #if MIN_VERSION_ghc(9,9,0) contextual :: HasLoc a => Context -> Bool -> Range -> a -> (ContextResult, Bool) #else @@ -254,15 +257,17 @@ contextual :: Context -> Bool -> Range -> GenLocated (SrcSpanAnn' a) e -> (Conte #endif contextual context shouldStop query s = let range = rangeOf s - in case range of - Nothing -> (mempty, True) - Just range | outside query range -> (mempty, True) - Just range -> (ContextResult range context, shouldStop) + in contInRange query range $ \range -> (ContextResult range context, shouldStop) --- * Helpers +-- | Run a continuation with the 'Range' of a source span, returning no context +-- if the span is missing or outside the query range. +contInRange :: Range -> Maybe Range -> (Range -> (ContextResult, Bool)) -> (ContextResult, Bool) +contInRange query range k = case range of + Nothing -> (NoContext, True) + Just range' | outside query range' -> (NoContext, True) + Just range' -> k range' -dominates :: Range -> Range -> Bool -dominates (Range s e) (Range qs qe) = s <= qs && qe <= e +-- * Helpers -- | A query range is outside a source range if it ends before the source -- starts, or it starts on a line after the source ends. @@ -272,6 +277,14 @@ dominates (Range s e) (Range qs qe) = s <= qs && qe <= e outside :: Range -> Range -> Bool outside (Range ps pe) (Range qs qe) = pe < qs || _line ps > _line qe +#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 + instance Pretty Context where pretty = \case TypeContext -> "type context" diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index b04a061864..cb6ccb3d55 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -9,7 +9,6 @@ module Development.IDE.Plugin.Completions.Logic ( , cacheDataProducer , localCompletionsForParsedModule , getCompletions -, deduceContext , fromIdentInfo , getCompletionPrefix , getCompletionPrefixFromRope @@ -46,8 +45,7 @@ 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 (..), - ContextMap) +import Development.IDE.Plugin.Completions.Context (Context (..)) import qualified Development.IDE.Plugin.Completions.Context as Context import Development.IDE.Plugin.Completions.Snippet import Development.IDE.Plugin.Completions.Types @@ -654,15 +652,6 @@ getCompletions let isLocal = maybe False (":" `T.isPrefixOf`) _detail (Down isQual, Down score, Down isLocal, _label, _detail) --- If we have a context tree, use it to determine which completion to show. -deduceContext :: Maybe (ContextMap, PositionMapping) -> Position -> Context -deduceContext maybeCtx pos = case maybeCtx of - Nothing -> DefaultContext - Just (ct, pmapping) -> - let PositionMapping pDelta = pmapping - position' = fromDelta pDelta pos - in Context.getContext ct position' - uniqueCompl :: CompItem -> CompItem -> Ordering uniqueCompl candidate unique = case compare (label candidate, compKind candidate)