From 26668f7415a28c6674894fc93aa6f45ba80f0d82 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Wed, 10 Nov 2021 10:42:27 +0000
Subject: [PATCH] Include sortText in completions and improve suggestions
(#2332)
* sort completions
* add an example
* Include fuzzy scores in completions sort text
* hlints
* Extend completion documentation to inform whether an identifier is alreaady imported
* Ditch alphabetical ordering - it's incompatible with qualified completions
* Fix bugs in completion help text
This fixes the ugly "Imported from 'Just B'" and other inconsistencies
* added tests for qualified completions
* Fix redundant import
* Inline Fuzzy.match to apply [1] and to be case-sensitive on first match
[1] - https://github.com/joom/fuzzy/pull/4
* fixup! Fix bugs in completion help text
* Sort qualified completions first
* Filter out global suggestions that overlap with local
For example, don't suggest GHC.Exts.fromList when Data.Map.fromList is in scope alraedy
* Sort completions alphabetically
* Show provenance in detail text
* Sort local/in-scope completions first
* Fix build with GHC 9
* Ignore func symbol tests
Co-authored-by: Alex Naspo <alex.naspo@protonmail.com>
Co-authored-by: Javier Neira <atreyu.bbb@gmail.com>
---
ghcide/src/Development/IDE/GHC/Compat/Core.hs | 20 +-
.../src/Development/IDE/Plugin/Completions.hs | 42 +++-
.../IDE/Plugin/Completions/Logic.hs | 198 +++++++++++++-----
.../IDE/Plugin/Completions/Types.hs | 8 +-
ghcide/src/Text/Fuzzy/Parallel.hs | 83 ++++++--
ghcide/test/exe/Main.hs | 67 ++++--
test/functional/Main.hs | 2 +-
7 files changed, 322 insertions(+), 98 deletions(-)
diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs
index b2f560e9..6bc9e50f 100644
--- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs
+++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs
@@ -190,7 +190,8 @@ module Development.IDE.GHC.Compat.Core (
SrcLoc.RealSrcSpan,
pattern RealSrcSpan,
SrcLoc.RealSrcLoc,
- SrcLoc.SrcLoc(..),
+ pattern RealSrcLoc,
+ SrcLoc.SrcLoc(SrcLoc.UnhelpfulLoc),
BufSpan,
SrcLoc.leftmost_smallest,
SrcLoc.containsSpan,
@@ -511,7 +512,7 @@ import GHC.Types.TyThing.Ppr
#else
import GHC.Types.Name.Set
#endif
-import GHC.Types.SrcLoc (BufSpan, SrcSpan (UnhelpfulSpan))
+import GHC.Types.SrcLoc (BufPos, BufSpan, SrcSpan (UnhelpfulSpan), SrcLoc(UnhelpfulLoc))
import qualified GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Unique.Supply
import GHC.Types.Var (Var (varName), setTyVarUnique,
@@ -637,10 +638,11 @@ import Var (Var (varName), setTyVarUnique,
#if MIN_VERSION_ghc(8,10,0)
import Coercion (coercionKind)
import Predicate
-import SrcLoc (SrcSpan (UnhelpfulSpan))
+import SrcLoc (SrcSpan (UnhelpfulSpan), SrcLoc (UnhelpfulLoc))
#else
import SrcLoc (RealLocated,
- SrcSpan (UnhelpfulSpan))
+ SrcSpan (UnhelpfulSpan),
+ SrcLoc (UnhelpfulLoc))
#endif
#endif
@@ -651,6 +653,7 @@ import System.FilePath
#if !MIN_VERSION_ghc(9,0,0)
type BufSpan = ()
+type BufPos = ()
#endif
pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan
@@ -662,6 +665,15 @@ pattern RealSrcSpan x y <- ((,Nothing) -> (SrcLoc.RealSrcSpan x, y)) where
#endif
{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-}
+pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Maybe BufPos-> SrcLoc.SrcLoc
+#if MIN_VERSION_ghc(9,0,0)
+pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y
+#else
+pattern RealSrcLoc x y <- ((,Nothing) -> (SrcLoc.RealSrcLoc x, y)) where
+ RealSrcLoc x _ = SrcLoc.RealSrcLoc x
+#endif
+{-# COMPLETE RealSrcLoc, UnhelpfulLoc #-}
+
pattern AvailTC :: Name -> [Name] -> [FieldLabel] -> Avail.AvailInfo
#if __GLASGOW_HASKELL__ >= 902
diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs
index 26fcd855..cf58bca1 100644
--- a/ghcide/src/Development/IDE/Plugin/Completions.hs
+++ b/ghcide/src/Development/IDE/Plugin/Completions.hs
@@ -30,7 +30,6 @@ import Development.IDE.GHC.ExactPrint (Annotated (annsA)
import Development.IDE.GHC.Util (prettyPrint)
import Development.IDE.Graph
import Development.IDE.Graph.Classes
-import qualified Development.IDE.Types.KnownTargets as KT
import Development.IDE.Plugin.CodeAction (newImport,
newImportToEdit)
import Development.IDE.Plugin.CodeAction.ExactPrint
@@ -39,6 +38,7 @@ import Development.IDE.Plugin.Completions.Types
import Development.IDE.Types.Exports
import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports),
hscEnv)
+import qualified Development.IDE.Types.KnownTargets as KT
import Development.IDE.Types.Location
import GHC.Exts (fromList, toList)
import GHC.Generics
@@ -47,6 +47,7 @@ import Ide.Types
import qualified Language.LSP.Server as LSP
import Language.LSP.Types
import qualified Language.LSP.VFS as VFS
+import Text.Fuzzy.Parallel (Scored (..))
descriptor :: PluginId -> PluginDescriptor IdeState
descriptor plId = (defaultPluginDescriptor plId)
@@ -156,17 +157,50 @@ getCompletionsLSP ide plId
let clientCaps = clientCapabilities $ shakeExtras ide
config <- getCompletionsConfig plId
allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports
- pure $ InL (List allCompletions)
+ pure $ InL (List $ orderedCompletions allCompletions)
_ -> return (InL $ List [])
_ -> return (InL $ List [])
_ -> return (InL $ List [])
+{- COMPLETION SORTING
+ We return an ordered set of completions (local -> nonlocal -> global).
+ Ordering is important because local/nonlocal are import aware, whereas
+ global are not and will always insert import statements, potentially redundant.
+
+ Moreover, the order prioritizes qualifiers, for instance, given:
+
+ import qualified MyModule
+ foo = MyModule.<complete>
+
+ The identifiers defined in MyModule will be listed first, followed by other
+ identifiers in importable modules.
+
+ According to the LSP specification, if no sortText is provided, the label is used
+ to sort alphabetically. Alphabetical ordering is almost never what we want,
+ so we force the LSP client to respect our ordering by using a numbered sequence.
+-}
+
+orderedCompletions :: [Scored CompletionItem] -> [CompletionItem]
+orderedCompletions [] = []
+orderedCompletions xx = zipWith addOrder [0..] xx
+ where
+ lxx = digits $ Prelude.length xx
+ digits = Prelude.length . show
+
+ addOrder :: Int -> Scored CompletionItem -> CompletionItem
+ addOrder n Scored{original = it@CompletionItem{_label,_sortText}} =
+ it{_sortText = Just $
+ T.pack(pad lxx n)
+ }
+
+ pad n x = let sx = show x in replicate (n - Prelude.length sx) '0' <> sx
+
----------------------------------------------------------------------------------------------------
toModueNameText :: KT.Target -> T.Text
toModueNameText target = case target of
- KT.TargetModule m -> T.pack $ moduleNameString m
- _ -> T.empty
+ KT.TargetModule m -> T.pack $ moduleNameString m
+ _ -> T.empty
extendImportCommand :: PluginCommand IdeState
extendImportCommand =
diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
index a345e248..e1a61cd7 100644
--- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
+++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
@@ -20,7 +20,6 @@ import Data.List.Extra as List hiding
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isJust,
- isNothing,
listToMaybe,
mapMaybe)
import qualified Data.Text as T
@@ -29,9 +28,11 @@ import qualified Text.Fuzzy.Parallel as Fuzzy
import Control.Monad
import Data.Aeson (ToJSON (toJSON))
import Data.Either (fromRight)
+import Data.Function (on)
import Data.Functor
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HashSet
+import Data.Ord (Down (Down))
import qualified Data.Set as Set
import Development.IDE.Core.Compile
import Development.IDE.Core.PositionMapping
@@ -52,6 +53,8 @@ import Ide.Types (CommandId (..),
import Language.LSP.Types
import Language.LSP.Types.Capabilities
import qualified Language.LSP.VFS as VFS
+import Text.Fuzzy.Parallel (Scored (score_),
+ original)
-- Chunk size used for parallelizing fuzzy matching
chunkSize :: Int
@@ -163,7 +166,7 @@ mkCompl
{ compKind,
isInfix,
insertText,
- importedFrom,
+ provenance,
typeText,
label,
docs,
@@ -174,7 +177,12 @@ mkCompl
{_label = label,
_kind = kind,
_tags = Nothing,
- _detail = (colon <>) <$> typeText,
+ _detail =
+ case (typeText, provenance) of
+ (Just t,_) -> Just $ colon <> t
+ (_, ImportedFrom mod) -> Just $ "from " <> mod
+ (_, DefinedIn mod) -> Just $ "from " <> mod
+ _ -> Nothing,
_documentation = documentation,
_deprecated = Nothing,
_preselect = Nothing,
@@ -192,23 +200,28 @@ mkCompl
where kind = Just compKind
docs' = imported : spanDocToMarkdown docs
- imported = case importedFrom of
- Left pos -> "*Defined at '" <> ppr pos <> "'*\n'"
- Right mod -> "*Defined in '" <> mod <> "'*\n"
+ imported = case provenance of
+ Local pos -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n'"
+ ImportedFrom mod -> "*Imported from '" <> mod <> "'*\n"
+ DefinedIn mod -> "*Defined in '" <> mod <> "'*\n"
colon = if optNewColonConvention then ": " else ":: "
documentation = Just $ CompletionDocMarkup $
MarkupContent MkMarkdown $
T.intercalate sectionSeparator docs'
+ pprLineCol :: SrcLoc -> T.Text
+ pprLineCol (UnhelpfulLoc fs) = T.pack $ unpackFS fs
+ pprLineCol (RealSrcLoc loc _) =
+ "line " <> ppr(srcLocLine loc) <> ", column " <> ppr(srcLocCol loc)
+
mkAdditionalEditsCommand :: PluginId -> ExtendImport -> Command
mkAdditionalEditsCommand pId edits =
mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits])
-mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
-mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI {..}
+mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> Provenance -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
+mkNameCompItem doc thingParent origName provenance thingType isInfix docs !imp = CI {..}
where
compKind = occNameToComKind typeText origName
- importedFrom = Right $ showModName origMod
isTypeCompl = isTcOcc origName
label = stripPrefix $ showGhc origName
insertText = case isInfix of
@@ -303,7 +316,7 @@ fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem
fromIdentInfo doc IdentInfo{..} q = CI
{ compKind= occNameToComKind Nothing name
, insertText=rendered
- , importedFrom=Right moduleNameText
+ , provenance = DefinedIn moduleNameText
, typeText=Nothing
, label=rendered
, isInfix=Nothing
@@ -324,6 +337,7 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do
let
packageState = hscEnv env
curModName = moduleName curMod
+ curModNameText = ppr curModName
importMap = Map.fromList [ (l, imp) | imp@(L (RealSrcSpan l _) _) <- limports ]
@@ -350,7 +364,7 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do
getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)
getComplsForOne (GRE n par True _) =
- (, mempty) <$> toCompItem par curMod curModName n Nothing
+ (, mempty) <$> toCompItem par curMod curModNameText n Nothing
getComplsForOne (GRE n par False prov) =
flip foldMapM (map is_decl prov) $ \spec -> do
let originalImportDecl = do
@@ -359,7 +373,7 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do
-- or if it doesn't have a real location
loc <- realSpan $Â is_dloc spec
Map.lookup loc importMap
- compItem <- toCompItem par curMod (is_mod spec) n originalImportDecl
+ compItem <- toCompItem par curMod (ppr $ is_mod spec) n originalImportDecl
let unqual
| is_qual spec = []
| otherwise = compItem
@@ -370,7 +384,7 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do
origMod = showModName (is_mod spec)
return (unqual,QualCompls qual)
- toCompItem :: Parent -> Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem]
+ toCompItem :: Parent -> Module -> T.Text -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem]
toCompItem par m mn n imp' = do
docs <- getDocumentationTryGhc packageState curMod n
let (mbParent, originName) = case par of
@@ -386,10 +400,10 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do
let recordCompls = case record_ty of
Just (ctxStr, flds) | not (null flds) ->
- [mkRecordSnippetCompItem uri mbParent ctxStr flds (ppr mn) docs imp']
+ [mkRecordSnippetCompItem uri mbParent ctxStr flds (ImportedFrom mn) docs imp']
_ -> []
- return $ mkNameCompItem uri mbParent originName mn ty Nothing docs imp'
+ return $ mkNameCompItem uri mbParent originName (ImportedFrom mn) ty Nothing docs imp'
: recordCompls
(unquals,quals) <- getCompls rdrElts
@@ -407,7 +421,7 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do
-- | Produces completions from the top level declarations of a module.
localCompletionsForParsedModule :: Uri -> ParsedModule -> CachedCompletions
-localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} =
+localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} =
CC { allModNamesAsNS = mempty
, unqualCompls = compls
, qualCompls = mempty
@@ -443,7 +457,7 @@ localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsMod
| id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x
, let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)]
-- here we only have to look at the outermost type
- recordCompls = findRecordCompl uri pm thisModName x
+ recordCompls = findRecordCompl uri pm (Local pos) x
in
-- the constructors and snippets will be duplicated here giving the user 2 choices.
generalCompls ++ recordCompls
@@ -452,18 +466,17 @@ localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsMod
ForD _ ForeignExport{fd_name,fd_sig_ty} ->
[mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)]
_ -> []
- | L _ decl <- hsmodDecls
+ | L pos decl <- hsmodDecls,
+ let mkComp = mkLocalComp pos
]
- mkComp n ctyp ty =
- CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiInterface]) Nothing
+ mkLocalComp pos n ctyp ty =
+ CI ctyp pn (Local pos) ty pn Nothing doc (ctyp `elem` [CiStruct, CiInterface]) Nothing
where
pn = ppr n
doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing)
- thisModName = ppr hsmodName
-
-findRecordCompl :: Uri -> ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem]
+findRecordCompl :: Uri -> ParsedModule -> Provenance -> TyClDecl GhcPs -> [CompItem]
findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result
where
result = [mkRecordSnippetCompItem uri (Just $ showNameWithoutUniques $ unLoc tcdLName)
@@ -525,13 +538,17 @@ getCompletions
-> ClientCapabilities
-> CompletionsConfig
-> HM.HashMap T.Text (HashSet.HashSet IdentInfo)
- -> IO [CompletionItem]
+ -> IO [Scored CompletionItem]
getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}
maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do
let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo
enteredQual = if T.null prefixModule then "" else prefixModule <> "."
fullPrefix = enteredQual <> prefixText
+ -- Boolean labels to tag suggestions as qualified (or not)
+ qual = not(T.null prefixModule)
+ notQual = False
+
{- correct the position by moving 'foo :: Int -> String -> '
^
to 'foo :: Int -> String -> '
@@ -541,12 +558,14 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
maxC = maxCompletions config
+ filtModNameCompls :: [Scored CompletionItem]
filtModNameCompls =
- map mkModCompl
- $ mapMaybe (T.stripPrefix enteredQual)
- $ Fuzzy.simpleFilter chunkSize maxC fullPrefix allModNamesAsNS
+ (fmap.fmap) mkModCompl
+ $ Fuzzy.simpleFilter chunkSize maxC fullPrefix
+ $ (if T.null enteredQual then id else mapMaybe (T.stripPrefix enteredQual))
+ allModNamesAsNS
- filtCompls = map Fuzzy.original $ Fuzzy.filter chunkSize maxC prefixText ctxCompls "" "" label False
+ filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls "" "" (label . snd)
where
mcc = case maybe_parsed of
@@ -561,11 +580,11 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
-- completions specific to the current context
ctxCompls' = case mcc of
Nothing -> compls
- Just TypeContext -> filter isTypeCompl compls
- Just ValueContext -> filter (not . isTypeCompl) compls
- Just _ -> filter (not . isTypeCompl) compls
+ Just TypeContext -> filter ( isTypeCompl . snd) compls
+ Just ValueContext -> filter (not . isTypeCompl . snd) compls
+ Just _ -> filter (not . isTypeCompl . snd) compls
-- Add whether the text to insert has backticks
- ctxCompls = map (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls'
+ ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls'
infixCompls :: Maybe Backtick
infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos
@@ -582,19 +601,17 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
ctyp = occNameToComKind Nothing occ
pn = ppr name
ty = ppr <$> typ
- thisModName = case nameModule_maybe name of
- Nothing -> Left $ nameSrcSpan name
- Just m -> Right $ ppr m
+ thisModName = Local $ nameSrcSpan name
compls = if T.null prefixModule
- then localCompls ++ unqualCompls ++ (($Nothing) <$> anyQualCompls)
- else Map.findWithDefault [] prefixModule (getQualCompls qualCompls)
- ++ (($ Just prefixModule) <$> anyQualCompls)
+ then map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls)
+ else ((qual,) <$> Map.findWithDefault [] prefixModule (getQualCompls qualCompls))
+ ++ ((notQual,) . ($ Just prefixModule) <$> anyQualCompls)
filtListWith f list =
- [ f label
+ [ fmap f label
| label <- Fuzzy.simpleFilter chunkSize maxC fullPrefix list
- , enteredQual `T.isPrefixOf` label
+ , enteredQual `T.isPrefixOf` original label
]
filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
@@ -621,25 +638,52 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
-> return []
| otherwise -> do
-- assumes that nubOrdBy is stable
- let uniqueFiltCompls = nubOrdBy uniqueCompl filtCompls
- let compls = map (mkCompl plId ideOpts) uniqueFiltCompls
- return $ filtModNameCompls
- ++ filtKeywordCompls
- ++ map (toggleSnippets caps config) compls
+ let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls
+ let compls = (fmap.fmap.fmap) (mkCompl plId ideOpts) uniqueFiltCompls
+ return $
+ (fmap.fmap) snd $
+ sortBy (compare `on` lexicographicOrdering) $
+ mergeListsBy (flip compare `on` score_)
+ [ (fmap.fmap) (notQual,) filtModNameCompls
+ , (fmap.fmap) (notQual,) filtKeywordCompls
+ , (fmap.fmap.fmap) (toggleSnippets caps config) compls
+ ]
+ where
+ -- We use this ordering to alphabetically sort suggestions while respecting
+ -- all the previously applied ordering sources. These are:
+ -- 1. Qualified suggestions go first
+ -- 2. Fuzzy score ranks next
+ -- 3. In-scope completions rank next
+ -- 4. label alphabetical ordering next
+ -- 4. detail alphabetical ordering (proxy for module)
+ lexicographicOrdering Fuzzy.Scored{score_, original} =
+ case original of
+ (isQual, CompletionItem{_label,_detail}) -> do
+ let isLocal = maybe False (":" `T.isPrefixOf`) _detail
+ (Down isQual, Down score_, Down isLocal, _label, _detail)
+
+
uniqueCompl :: CompItem -> CompItem -> Ordering
-uniqueCompl x y =
- case compare (label x, importedFrom x, compKind x)
- (label y, importedFrom y, compKind y) of
+uniqueCompl candidate unique =
+ case compare (label candidate, compKind candidate)
+ (label unique, compKind unique) of
EQ ->
-- preserve completions for duplicate record fields where the only difference is in the type
- -- remove redundant completions with less type info
- if typeText x == typeText y
- || isNothing (typeText x)
- || isNothing (typeText y)
+ -- remove redundant completions with less type info than the previous
+ if (typeText candidate == typeText unique && isLocalCompletion unique)
+ -- filter global completions when we already have a local one
+ || not(isLocalCompletion candidate) && isLocalCompletion unique
then EQ
- else compare (insertText x) (insertText y)
+ else compare (importedFrom candidate, insertText candidate) (importedFrom unique, insertText unique)
other -> other
+ where
+ isLocalCompletion ci = isJust(typeText ci)
+
+ importedFrom :: CompItem -> T.Text
+ importedFrom (provenance -> ImportedFrom m) = m
+ importedFrom (provenance -> DefinedIn m) = m
+ importedFrom (provenance -> Local _) = "local"
-- ---------------------------------------------------------------------
-- helper functions for infix backticks
@@ -745,13 +789,13 @@ safeTyThingForRecord (AConLike dc) =
Just (ctxStr, field_names)
safeTyThingForRecord _ = Nothing
-mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
-mkRecordSnippetCompItem uri parent ctxStr compl mn docs imp = r
+mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem
+mkRecordSnippetCompItem uri parent ctxStr compl importedFrom docs imp = r
where
r = CI {
compKind = CiSnippet
, insertText = buildSnippet
- , importedFrom = importedFrom
+ , provenance = importedFrom
, typeText = Nothing
, label = ctxStr
, isInfix = Nothing
@@ -771,9 +815,49 @@ mkRecordSnippetCompItem uri parent ctxStr compl mn docs imp = r
snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs
snippet = T.intercalate (T.pack ", ") snippet_parts
buildSnippet = ctxStr <> " {" <> snippet <> "}"
- importedFrom = Right mn
getImportQual :: LImportDecl GhcPs -> Maybe T.Text
getImportQual (L _ imp)
| isQualifiedImport imp = Just $ T.pack $ moduleNameString $ maybe (unLoc $ ideclName imp) unLoc (ideclAs imp)
| otherwise = Nothing
+
+--------------------------------------------------------------------------------
+
+-- This comes from the GHC.Utils.Misc module (not exported)
+-- | Merge an unsorted list of sorted lists, for example:
+--
+-- > mergeListsBy compare [ [2,5,15], [1,10,100] ] = [1,2,5,10,15,100]
+--
+-- \( O(n \log{} k) \)
+mergeListsBy :: forall a. (a -> a -> Ordering) -> [[a]] -> [a]
+mergeListsBy cmp all_lists = merge_lists all_lists
+ where
+ -- Implements "Iterative 2-Way merge" described at
+ -- https://en.wikipedia.org/wiki/K-way_merge_algorithm
+
+ -- Merge two sorted lists into one in O(n).
+ merge2 :: [a] -> [a] -> [a]
+ merge2 [] ys = ys
+ merge2 xs [] = xs
+ merge2 (x:xs) (y:ys) =
+ case cmp x y of
+ Prelude.GT -> y : merge2 (x:xs) ys
+ _ -> x : merge2 xs (y:ys)
+
+ -- Merge the first list with the second, the third with the fourth, and so
+ -- on. The output has half as much lists as the input.
+ merge_neighbours :: [[a]] -> [[a]]
+ merge_neighbours [] = []
+ merge_neighbours [xs] = [xs]
+ merge_neighbours (xs : ys : lists) =
+ merge2 xs ys : merge_neighbours lists
+
+ -- Since 'merge_neighbours' halves the amount of lists in each iteration,
+ -- we perform O(log k) iteration. Each iteration is O(n). The total running
+ -- time is therefore O(n log k).
+ merge_lists :: [[a]] -> [a]
+ merge_lists lists =
+ case merge_neighbours lists of
+ [] -> []
+ [xs] -> xs
+ lists' -> merge_lists lists'
diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs
index 414f3048..510d30ac 100644
--- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs
+++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs
@@ -66,10 +66,16 @@ data ExtendImport = ExtendImport
deriving (Eq, Show, Generic)
deriving anyclass (FromJSON, ToJSON)
+data Provenance
+ = ImportedFrom Text
+ | DefinedIn Text
+ | Local SrcSpan
+ deriving (Eq, Ord, Show)
+
data CompItem = CI
{ compKind :: CompletionItemKind
, insertText :: T.Text -- ^ Snippet for the completion
- , importedFrom :: Either SrcSpan T.Text -- ^ From where this item is imported from.
+ , provenance :: Provenance -- ^ From where this item is imported from.
, typeText :: Maybe T.Text -- ^ Available type information.
, label :: T.Text -- ^ Label to display to the user.
, isInfix :: Maybe Backtick -- ^ Did the completion happen
diff --git a/ghcide/src/Text/Fuzzy/Parallel.hs b/ghcide/src/Text/Fuzzy/Parallel.hs
index 700cad45..e90aa704 100644
--- a/ghcide/src/Text/Fuzzy/Parallel.hs
+++ b/ghcide/src/Text/Fuzzy/Parallel.hs
@@ -2,9 +2,9 @@
module Text.Fuzzy.Parallel
( filter,
simpleFilter,
+ Scored(..),
-- reexports
- Fuzzy(..),
- match
+ Fuzzy,
) where
import Control.Monad.ST (runST)
@@ -15,9 +15,58 @@ import Data.Vector (Vector, (!))
import qualified Data.Vector as V
-- need to use a stable sort
import Data.Bifunctor (second)
-import Data.Maybe (fromJust)
+import Data.Char (toLower)
+import Data.Maybe (fromMaybe)
+import qualified Data.Monoid.Textual as T
import Prelude hiding (filter)
-import Text.Fuzzy (Fuzzy (..), match)
+import Text.Fuzzy (Fuzzy (..))
+
+data Scored a = Scored {score_ :: !Int, original:: !a}
+ deriving (Functor,Show)
+
+-- | Returns the rendered output and the
+-- matching score for a pattern and a text.
+-- Two examples are given below:
+--
+-- >>> match "fnt" "infinite" "" "" id True
+-- Just ("infinite",3)
+--
+-- >>> match "hsk" ("Haskell",1995) "<" ">" fst False
+-- Just ("<h>a<s><k>ell",5)
+--
+{-# INLINABLE match #-}
+
+match :: (T.TextualMonoid s)
+ => s -- ^ Pattern in lowercase except for first character
+ -> t -- ^ The value containing the text to search in.
+ -> s -- ^ The text to add before each match.
+ -> s -- ^ The text to add after each match.
+ -> (t -> s) -- ^ The function to extract the text from the container.
+ -> Maybe (Fuzzy t s) -- ^ The original value, rendered string and score.
+match pattern t pre post extract =
+ if null pat then Just (Fuzzy t result totalScore) else Nothing
+ where
+ null :: (T.TextualMonoid s) => s -> Bool
+ null = not . T.any (const True)
+
+ s = extract t
+ (totalScore, _currScore, result, pat, _) =
+ T.foldl'
+ undefined
+ (\(tot, cur, res, pat, isFirst) c ->
+ case T.splitCharacterPrefix pat of
+ Nothing -> (tot, 0, res <> T.singleton c, pat, isFirst)
+ Just (x, xs) ->
+ -- the case of the first character has to match
+ -- otherwise use lower case since the pattern is assumed lower
+ let !c' = if isFirst then c else toLower c in
+ if x == c' then
+ let cur' = cur * 2 + 1 in
+ (tot + cur', cur', res <> pre <> T.singleton c <> post, xs, False)
+ else (tot, 0, res <> T.singleton c, pat, isFirst)
+ ) ( 0
+ , 1 -- matching at the start gives a bonus (cur = 1)
+ , mempty, pattern, True) s
-- | The function to filter a list of values by fuzzy search on the text extracted from them.
filter :: (TextualMonoid s)
@@ -28,15 +77,20 @@ filter :: (TextualMonoid s)
-> s -- ^ The text to add before each match.
-> s -- ^ The text to add after each match.
-> (t -> s) -- ^ The function to extract the text from the container.
- -> Bool -- ^ Case sensitivity.
- -> [Fuzzy t s] -- ^ The list of results, sorted, highest score first.
-filter chunkSize maxRes pattern ts pre post extract caseSen = runST $ do
+ -> [Scored t] -- ^ The list of results, sorted, highest score first.
+filter chunkSize maxRes pattern ts pre post extract = runST $ do
let v = V.mapMaybe id
- (V.map (\t -> match pattern t pre post extract caseSen) (V.fromList ts)
+ (V.map (\t -> match pattern' t pre post extract) (V.fromList ts)
`using`
parVectorChunk chunkSize (evalTraversable forceScore))
- perfectScore = score $ fromJust $ match pattern pattern "" "" id False
+ perfectScore = score $ fromMaybe (error $ T.toString undefined pattern) $
+ match pattern' pattern' "" "" id
return $ partialSortByAscScore maxRes perfectScore v
+ where
+ -- Preserve case for the first character, make all others lowercase
+ pattern' = case T.splitCharacterPrefix pattern of
+ Just (c, rest) -> T.singleton c <> T.map toLower rest
+ _ -> pattern
-- | Return all elements of the list that have a fuzzy
-- match against the pattern. Runs with default settings where
@@ -50,9 +104,9 @@ simpleFilter :: (TextualMonoid s)
-> Int -- ^ Max. number of results wanted
-> s -- ^ Pattern to look for.
-> [s] -- ^ List of texts to check.
- -> [s] -- ^ The ones that match.
+ -> [Scored s] -- ^ The ones that match.
simpleFilter chunk maxRes pattern xs =
- map original $ filter chunk maxRes pattern xs mempty mempty id False
+ filter chunk maxRes pattern xs mempty mempty id
--------------------------------------------------------------------------------
@@ -102,7 +156,7 @@ partialSortByAscScore :: TextualMonoid s
=> Int -- ^ Number of items needed
-> Int -- ^ Value of a perfect score
-> Vector (Fuzzy t s)
- -> [Fuzzy t s]
+ -> [Scored t]
partialSortByAscScore wantedCount perfectScore v = loop 0 (SortState minBound perfectScore 0) [] where
l = V.length v
loop index st@SortState{..} acc
@@ -115,12 +169,15 @@ partialSortByAscScore wantedCount perfectScore v = loop 0 (SortState minBound pe
| otherwise =
case v!index of
x | score x == scoreWanted
- -> loop (index+1) st{foundCount = foundCount+1} (x:acc)
+ -> loop (index+1) st{foundCount = foundCount+1} (toScored x:acc)
| score x < scoreWanted && score x > bestScoreSeen
-> loop (index+1) st{bestScoreSeen = score x} acc
| otherwise
-> loop (index+1) st acc
+toScored :: TextualMonoid s => Fuzzy t s -> Scored t
+toScored Fuzzy{..} = Scored score original
+
data SortState a = SortState
{ bestScoreSeen :: !Int
, scoreWanted :: !Int
diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs
index eec662dc..14fa2f6a 100644
--- a/ghcide/test/exe/Main.hs
+++ b/ghcide/test/exe/Main.hs
@@ -4112,7 +4112,8 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do
completionTests :: TestTree
completionTests
= testGroup "completion"
- [ testGroup "non local" nonLocalCompletionTests
+ [
+ testGroup "non local" nonLocalCompletionTests
, testGroup "topLevel" topLevelCompletionTests
, testGroup "local" localCompletionTests
, testGroup "package" packageCompletionTests
@@ -4193,15 +4194,13 @@ topLevelCompletionTests = [
"variable"
["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
(Position 0 8)
- [("xxx", CiFunction, "xxx", True, True, Nothing),
- ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)
+ [("xxx", CiFunction, "xxx", True, True, Nothing)
],
completionTest
"constructor"
["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
(Position 0 8)
- [("xxx", CiFunction, "xxx", True, True, Nothing),
- ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)
+ [("xxx", CiFunction, "xxx", True, True, Nothing)
],
completionTest
"class method"
@@ -4315,17 +4314,15 @@ nonLocalCompletionTests =
[("head", CiFunction, "head ${1:([a])}", True, True, Nothing)],
completionTest
"constructor"
- ["module A where", "f = Tru"]
- (Position 1 7)
- [ ("True", CiConstructor, "True ", True, True, Nothing),
- ("truncate", CiFunction, "truncate ${1:a}", True, True, Nothing)
+ ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"]
+ (Position 2 8)
+ [ ("True", CiConstructor, "True ", True, True, Nothing)
],
completionTest
"type"
- ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]
- (Position 2 7)
- [ ("Bounded", CiInterface, "Bounded ${1:(*)}", True, True, Nothing),
- ("Bool", CiStruct, "Bool ", True, True, Nothing)
+ ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"]
+ (Position 2 8)
+ [ ("Bool", CiStruct, "Bool ", True, True, Nothing)
],
completionTest
"qualified"
@@ -4335,8 +4332,8 @@ nonLocalCompletionTests =
],
completionTest
"duplicate import"
- ["module A where", "import Data.List", "import Data.List", "f = perm"]
- (Position 3 8)
+ ["module A where", "import Data.List", "import Data.List", "f = permu"]
+ (Position 3 9)
[ ("permutations", CiFunction, "permutations ${1:([a])}", False, False, Nothing)
],
completionTest
@@ -4512,7 +4509,7 @@ otherCompletionTests = [
_ <- waitForDiagnostics
compls <- getCompletions docA $ Position 2 4
let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"]
- liftIO $ take 2 compls' @?= ["member ${1:Foo}", "member ${1:Bar}"],
+ liftIO $ take 2 compls' @?= ["member ${1:Bar}", "member ${1:Foo}"],
testSessionWait "maxCompletions" $ do
doc <- createDoc "A.hs" "haskell" $ T.unlines
@@ -4607,7 +4604,7 @@ packageCompletionTests =
, _label == "fromList"
]
liftIO $ take 3 compls' @?=
- map Just ["fromList ${1:([Item l])}", "fromList", "fromList"]
+ map Just ["fromList ${1:([Item l])}"]
, testGroup "auto import snippets"
[ completionCommandTest
"import Data.Sequence"
@@ -4664,7 +4661,41 @@ projectCompletionTests =
compls <- getCompletions doc (Position 1 13)
let item = head $ filter ((== "ALocalModule") . (^. Lens.label)) compls
liftIO $ do
- item ^. Lens.label @?= "ALocalModule"
+ item ^. Lens.label @?= "ALocalModule",
+ testSession' "auto complete functions from qualified imports without alias" $ \dir-> do
+ liftIO $ writeFile (dir </> "hie.yaml")
+ "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"
+ _ <- createDoc "A.hs" "haskell" $ T.unlines
+ [ "module A (anidentifier) where",
+ "anidentifier = ()"
+ ]
+ _ <- waitForDiagnostics
+ doc <- createDoc "B.hs" "haskell" $ T.unlines
+ [ "module B where",
+ "import qualified A",
+ "A."
+ ]
+ compls <- getCompletions doc (Position 2 2)
+ let item = head compls
+ liftIO $ do
+ item ^. L.label @?= "anidentifier",
+ testSession' "auto complete functions from qualified imports with alias" $ \dir-> do
+ liftIO $ writeFile (dir </> "hie.yaml")
+ "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"
+ _ <- createDoc "A.hs" "haskell" $ T.unlines
+ [ "module A (anidentifier) where",
+ "anidentifier = ()"
+ ]
+ _ <- waitForDiagnostics
+ doc <- createDoc "B.hs" "haskell" $ T.unlines
+ [ "module B where",
+ "import qualified A as Alias",
+ "foo = Alias."
+ ]
+ compls <- getCompletions doc (Position 2 12)
+ let item = head compls
+ liftIO $ do
+ item ^. L.label @?= "anidentifier"
]
highlightTests :: TestTree
diff --git a/test/functional/Main.hs b/test/functional/Main.hs
index da12500f..119db307 100644
--- a/test/functional/Main.hs
+++ b/test/functional/Main.hs
@@ -36,6 +36,6 @@ main = defaultTestRunner
, Highlight.tests
, ignoreInEnv [HostOS Windows, GhcVer GHC90] "Tests gets stuck in ci" $ Progress.tests
, Reference.tests
- , Symbol.tests
+ , ignoreInEnv [HostOS Windows, GhcVer GHC90] "Tests gets stuck in ci" $ Symbol.tests
, TypeDefinition.tests
]
--
GitLab