From 4b4e21d8d7efb8b6737dea3d893dfdea4a6c6a15 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 21 Sep 2022 10:14:04 +0530 Subject: [PATCH 1/4] Implement completionItem/resolve --- ghcide/src/Development/IDE/Core/Compile.hs | 55 +++-- ghcide/src/Development/IDE/GHC/Compat.hs | 20 ++ ghcide/src/Development/IDE/GHC/Compat/Core.hs | 7 + .../src/Development/IDE/Plugin/Completions.hs | 60 ++++- .../IDE/Plugin/Completions/Logic.hs | 220 +++++++----------- .../IDE/Plugin/Completions/Types.hs | 70 +++++- .../Development/IDE/Spans/Documentation.hs | 25 +- ghcide/test/exe/Main.hs | 68 +++--- hls-plugin-api/src/Ide/Types.hs | 19 +- .../new/src/Wingman/Machinery.hs | 2 +- .../old/src/Wingman/Machinery.hs | 2 +- 11 files changed, 334 insertions(+), 214 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 86bceb6deb..389fbfbf11 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -1592,15 +1592,14 @@ coreFileToLinkable linkableType session ms iface details core_file t = do --- and leads to fun errors like "Cannot continue after interface file error". getDocsBatch :: HscEnv - -> Module -- ^ a module where the names are in scope -> [Name] #if MIN_VERSION_ghc(9,3,0) -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))] #else -> IO [Either String (Maybe HsDocString, IntMap HsDocString)] #endif -getDocsBatch hsc_env _mod _names = do - (msgs, res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name -> +getDocsBatch hsc_env _names = do + res <- initIfaceLoad hsc_env $ forM _names $ \name -> case nameModule_maybe name of Nothing -> return (Left $ NameHasNoModule name) Just mod -> do @@ -1615,7 +1614,7 @@ getDocsBatch hsc_env _mod _names = do , mi_decl_docs = DeclDocMap dmap , mi_arg_docs = ArgDocMap amap #endif - } <- loadModuleInterface "getModuleInterface" mod + } <- loadSysInterface (text "getModuleInterface") mod #if MIN_VERSION_ghc(9,3,0) if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap #else @@ -1636,44 +1635,42 @@ getDocsBatch hsc_env _mod _names = do #else Map.findWithDefault mempty name amap)) #endif - case res of - Just x -> return $ map (first $ T.unpack . printOutputable) - $ x - Nothing -> throwErrors -#if MIN_VERSION_ghc(9,3,0) - $ fmap GhcTcRnMessage msgs -#elif MIN_VERSION_ghc(9,2,0) - $ Error.getErrorMessages msgs -#else - $ snd msgs -#endif + return $ map (first $ T.unpack . printOutputable) + $ res where - throwErrors = liftIO . throwIO . mkSrcErr compiled n = -- TODO: Find a more direct indicator. case nameSrcLoc n of RealSrcLoc {} -> False UnhelpfulLoc {} -> True -fakeSpan :: RealSrcSpan -fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "") 1 1 - -- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. -- The interactive paths create problems in ghc-lib builds --- and leads to fun errors like "Cannot continue after interface file error". lookupName :: HscEnv - -> Module -- ^ A module where the Names are in scope -> Name -> IO (Maybe TyThing) -lookupName hsc_env mod name = do - (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do - tcthing <- tcLookup name - case tcthing of - AGlobal thing -> return thing - ATcId{tct_id=id} -> return (AnId id) - _ -> panic "tcRnLookupName'" - return res - +lookupName _ name + | Nothing <- nameModule_maybe name = pure Nothing +lookupName hsc_env name = do +#if MIN_VERSION_ghc(9,2,0) + mb_thing <- liftIO $ lookupType hsc_env name +#else + eps <- liftIO $ readIORef (hsc_EPS hsc_env) + let mb_thing = lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name +#endif + case mb_thing of + x@(Just _) -> return x + Nothing + | x@(Just thing) <- wiredInNameTyThing_maybe name + -> do when (needWiredInHomeIface thing) + (initIfaceLoad hsc_env (loadWiredInHomeIface name)) + return x + | otherwise -> do + res <- initIfaceLoad hsc_env $ importDecl name + case res of + Util.Succeeded x -> return (Just x) + _ -> return Nothing pathToModuleName :: FilePath -> ModuleName pathToModuleName = mkModuleName . map rep diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 216039cd1c..b14b62a89a 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -22,6 +22,7 @@ module Development.IDE.GHC.Compat( #else upNameCache, #endif + lookupNameCache, disableWarningsAsErrors, reLoc, reLocA, @@ -416,6 +417,25 @@ hieExportNames = nameListFromAvails . hie_exports #if MIN_VERSION_ghc(9,3,0) type NameCacheUpdater = NameCache #else + +lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name) +-- Lookup up the (Module,OccName) in the NameCache +-- If you find it, return it; if not, allocate a fresh original name and extend +-- the NameCache. +-- Reason: this may the first occurrence of (say) Foo.bar we have encountered. +-- If we need to explore its value we will load Foo.hi; but meanwhile all we +-- need is a Name for it. +lookupNameCache mod occ name_cache = + case lookupOrigNameCache (nsNames name_cache) mod occ of { + Just name -> (name_cache, name); + Nothing -> + case takeUniqFromSupply (nsUniqs name_cache) of { + (uniq, us) -> + let + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache (nsNames name_cache) mod occ name + in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }} + upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c upNameCache = updNameCache #endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 56579f6130..4f139f7a07 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -36,7 +36,14 @@ module Development.IDE.GHC.Compat.Core ( maxRefHoleFits, maxValidHoleFits, setOutputFile, + lookupType, + needWiredInHomeIface, + loadWiredInHomeIface, + loadSysInterface, + importDecl, +#if MIN_VERSION_ghc(8,8,0) CommandLineOption, +#endif #if !MIN_VERSION_ghc(9,2,0) staticPlugins, #endif diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index b19b396aa3..bbfa7dc6c3 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -12,21 +12,27 @@ module Development.IDE.Plugin.Completions import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (readTVarIO) import Control.Monad.IO.Class +import Control.Lens ((&), (.~)) import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set +import Data.Aeson import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.PositionMapping +import Development.IDE.Core.Compile import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log, LogShake) import Development.IDE.Core.Shake hiding (Log) 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.Spans.Common +import Development.IDE.Spans.Documentation import Development.IDE.Plugin.Completions.Logic import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports), +import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports, envVisibleModuleNames), hscEnv) import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location @@ -37,6 +43,8 @@ import Development.IDE.Types.Logger (Pretty (pretty), import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types +import qualified Language.LSP.Types.Lens as J +import qualified Language.LSP.VFS as VFS import Numeric.Natural import Text.Fuzzy.Parallel (Scored (..)) @@ -57,10 +65,12 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP + <> mkPluginHandler SCompletionItemResolve resolveCompletion , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} , pluginPriority = ghcideCompletionsPluginPriority } + produceCompletions :: Recorder (WithPriority Log) -> Rules () produceCompletions recorder = do define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do @@ -85,8 +95,9 @@ produceCompletions recorder = do (global, inScope) <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> msrImports) `concurrently` tcRnImportDecls env msrImports case (global, inScope) of ((_, Just globalEnv), (_, Just inScopeEnv)) -> do + visibleMods <- liftIO $ fmap (fromMaybe []) $ envVisibleModuleNames sess let uri = fromNormalizedUri $ normalizedFilePathToUri file - cdata <- liftIO $ cacheDataProducer uri sess (ms_mod msrModSummary) globalEnv inScopeEnv msrImports + let cdata = cacheDataProducer uri visibleMods (ms_mod msrModSummary) globalEnv inScopeEnv msrImports return ([], Just cdata) (_diag, _) -> return ([], Nothing) @@ -102,6 +113,49 @@ dropListFromImportDecl iDecl = let f x = x in f <$> iDecl +resolveCompletion :: IdeState -> PluginId -> CompletionItem -> LSP.LspM Config (Either ResponseError CompletionItem) +resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_xdata} + | Just resolveData <- _xdata + , Success (CompletionResolveData uri needType (NameDetails mod occ)) <- fromJSON resolveData + , Just file <- uriToNormalizedFilePath $ toNormalizedUri uri + = liftIO $ runIdeAction "Completion resolve" (shakeExtras ide) $ do + msess <- useWithStaleFast GhcSessionDeps file + case msess of + Nothing -> pure (Right comp) -- File doesn't compile, return original completion item + Just (sess,_) -> do + let nc = ideNc $ shakeExtras ide +#if MIN_VERSION_ghc(9,3,0) + name <- liftIO $ lookupNameCache nc mod occ +#else + name <- liftIO $ upNameCache nc (lookupNameCache mod occ) +#endif + mdkm <- useWithStaleFast GetDocMap file + let (dm,km) = case mdkm of + Just (DKMap dm km, _) -> (dm,km) + Nothing -> (mempty, mempty) + doc <- case lookupNameEnv dm name of + Just doc -> pure $ spanDocToMarkdown doc + Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name + typ <- case lookupNameEnv km name of + _ | not needType -> pure Nothing + Just ty -> pure (safeTyThingType ty) + Nothing -> do + (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name) + let det1 = case typ of + Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n") + Nothing -> Nothing + doc1 = case _documentation of + Just (CompletionDocMarkup (MarkupContent MkMarkdown old)) -> + CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator (old:doc) + _ -> CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator doc + pure (Right $ comp & J.detail .~ (det1 <> _detail) + & J.documentation .~ Just doc1 + ) + where + stripForall ty = case splitForAllTyCoVars ty of + (_,res) -> res +resolveCompletion _ _ comp = pure (Right comp) + -- | Generate code actions. getCompletionsLSP :: IdeState @@ -160,7 +214,7 @@ getCompletionsLSP ide plId plugins = idePlugins $ shakeExtras ide config <- liftIO $ runAction "" ide $ getCompletionsConfig plId - allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports + allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri pure $ InL (List $ orderedCompletions allCompletions) _ -> return (InL $ List []) _ -> return (InL $ List []) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index b6f652fbf0..c93a9d23e4 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -22,13 +22,12 @@ import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe, - mapMaybe) + mapMaybe, isNothing) import qualified Data.Text as T 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 @@ -153,16 +152,12 @@ getCContext pos pm | otherwise = Nothing importInline _ _ = Nothing -occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind -occNameToComKind ty oc +occNameToComKind :: OccName -> CompletionItemKind +occNameToComKind oc | isVarOcc oc = case occNameString oc of i:_ | isUpper i -> CiConstructor _ -> CiFunction - | isTcOcc oc = case ty of - Just t - | "Constraint" `T.isSuffixOf` t - -> CiInterface - _ -> CiStruct + | isTcOcc oc = CiStruct | isDataOcc oc = CiConstructor | otherwise = CiVariable @@ -171,19 +166,20 @@ showModName :: ModuleName -> T.Text showModName = T.pack . moduleNameString mkCompl :: Maybe PluginId -- ^ Plugin to use for the extend import command - -> IdeOptions -> CompItem -> CompletionItem + -> IdeOptions -> Uri -> CompItem -> CompletionItem mkCompl pId IdeOptions {..} + uri CI { compKind, isInfix, insertText, provenance, - typeText, label, - docs, - additionalTextEdits + typeText, + additionalTextEdits, + nameDetails } = do let mbCommand = mkAdditionalEditsCommand pId =<< additionalTextEdits let ci = CompletionItem @@ -192,7 +188,7 @@ mkCompl _tags = Nothing, _detail = case (typeText, provenance) of - (Just t,_) | not(T.null t) -> Just $ colon <> t + (Just t,_) | not(T.null t) -> Just $ ":: " <> t (_, ImportedFrom mod) -> Just $ "from " <> mod (_, DefinedIn mod) -> Just $ "from " <> mod _ -> Nothing, @@ -208,16 +204,15 @@ mkCompl _additionalTextEdits = Nothing, _commitCharacters = Nothing, _command = mbCommand, - _xdata = Nothing} + _xdata = toJSON <$> fmap (CompletionResolveData uri (isNothing typeText)) nameDetails} removeSnippetsWhen (isJust isInfix) ci where kind = Just compKind - docs' = imported : spanDocToMarkdown docs + docs' = [imported] 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' @@ -231,22 +226,20 @@ mkAdditionalEditsCommand :: Maybe PluginId -> ExtendImport -> Maybe Command mkAdditionalEditsCommand (Just pId) edits = Just $ mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) mkAdditionalEditsCommand _ _ = Nothing -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 {..} +mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> Provenance -> Maybe Backtick -> Maybe (LImportDecl GhcPs) -> Maybe Module -> CompItem +mkNameCompItem doc thingParent origName provenance isInfix !imp mod = CI {..} where - compKind = occNameToComKind typeText origName + isLocalCompletion = True + nameDetails = NameDetails <$> mod <*> pure origName + compKind = occNameToComKind origName isTypeCompl = isTcOcc origName + typeText = Nothing label = stripPrefix $ printOutputable origName insertText = case isInfix of - Nothing -> case getArgText <$> thingType of - Nothing -> label - Just argText -> if T.null argText then label else label <> " " <> argText + Nothing -> label Just LeftSide -> label <> "`" Just Surrounded -> label - typeText - | Just t <- thingType = Just . stripForall $ printOutputable t - | otherwise = Nothing additionalTextEdits = imp <&> \x -> ExtendImport @@ -257,44 +250,6 @@ mkNameCompItem doc thingParent origName provenance thingType isInfix docs !imp = newThing = printOutputable origName } - stripForall :: T.Text -> T.Text - stripForall t - | T.isPrefixOf "forall" t = - -- We drop 2 to remove the '.' and the space after it - T.drop 2 (T.dropWhile (/= '.') t) - | otherwise = t - - getArgText :: Type -> T.Text - getArgText typ = argText - where - argTypes = getArgs typ - argText :: T.Text - argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes - snippet :: Int -> Type -> T.Text - snippet i t = case t of - (TyVarTy _) -> noParensSnippet - (LitTy _) -> noParensSnippet - (TyConApp _ []) -> noParensSnippet - _ -> snippetText i ("(" <> showForSnippet t <> ")") - where - noParensSnippet = snippetText i (showForSnippet t) - snippetText i t = "${" <> T.pack (show i) <> ":" <> t <> "}" - getArgs :: Type -> [Type] - getArgs t - | isPredTy t = [] - | isDictTy t = [] - | isForAllTy t = getArgs $ snd (splitForAllTyCoVars t) - | isFunTy t = - let (args, ret) = splitFunTys t - in if isForAllTy ret - then getArgs ret - else Prelude.filter (not . isDictTy) $ map scaledThing args - | isPiTy t = getArgs $ snd (splitPiTys t) - | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t - = getArgs t - | otherwise = [] - - showForSnippet :: Outputable a => a -> T.Text #if MIN_VERSION_ghc(9,2,0) showForSnippet x = T.pack $ renderWithContext ctxt $ GHC.ppr x -- FIXme @@ -333,13 +288,12 @@ mkExtCompl label = fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem fromIdentInfo doc IdentInfo{..} q = CI - { compKind= occNameToComKind Nothing name + { compKind= occNameToComKind name , insertText=rendered , provenance = DefinedIn moduleNameText - , typeText=Nothing , label=rendered + , typeText = Nothing , isInfix=Nothing - , docs=emptySpanDoc , isTypeCompl= not isDatacon && isUpper (T.head rendered) , additionalTextEdits= Just $ ExtendImport @@ -349,13 +303,13 @@ fromIdentInfo doc IdentInfo{..} q = CI importQual = q, newThing = rendered } + , nameDetails = Nothing + , isLocalCompletion = False } -cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions -cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do - let - packageState = hscEnv env - curModName = moduleName curMod +cacheDataProducer :: Uri -> [ModuleName] -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> CachedCompletions +cacheDataProducer uri visibleMods curMod globalEnv inScopeEnv limports = + let curModName = moduleName curMod curModNameText = printOutputable curModName importMap = Map.fromList [ (l, imp) | imp@(L (locA -> (RealSrcSpan l _)) _) <- limports ] @@ -374,26 +328,36 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do rdrElts = globalRdrEnvElts globalEnv - foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b - foldMapM f xs = foldr step return xs mempty where - step x r z = f x >>= \y -> r $! z `mappend` y + -- construct a map from Parents(type) to their fields + fieldMap = Map.fromListWith (++) $ flip mapMaybe rdrElts $ \elt -> do +#if MIN_VERSION_ghc(9,2,0) + par <- greParent_maybe elt + flbl <- greFieldLabel elt + Just (par,[flLabel flbl]) +#else + case gre_par elt of + FldParent n ml -> do + l <- ml + Just (n, [l]) + _ -> Nothing +#endif - getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls) - getCompls = foldMapM getComplsForOne + getCompls :: [GlobalRdrElt] -> ([CompItem],QualCompls) + getCompls = foldMap getComplsForOne - getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls) + getComplsForOne :: GlobalRdrElt -> ([CompItem],QualCompls) getComplsForOne (GRE n par True _) = - (, mempty) <$> toCompItem par curMod curModNameText n Nothing + (toCompItem par curMod curModNameText n Nothing, mempty) getComplsForOne (GRE n par False prov) = - flip foldMapM (map is_decl prov) $ \spec -> do + flip foldMap (map is_decl prov) $ \spec -> let originalImportDecl = do -- we don't want to extend import if it's already in scope guard . null $ lookupGRE_Name inScopeEnv n -- or if it doesn't have a real location loc <- realSpan $ is_dloc spec Map.lookup loc importMap - compItem <- toCompItem par curMod (printOutputable $ is_mod spec) n originalImportDecl - let unqual + compItem = toCompItem par curMod (printOutputable $ is_mod spec) n originalImportDecl + unqual | is_qual spec = [] | otherwise = compItem qual @@ -401,38 +365,34 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)] asMod = showModName (is_as spec) origMod = showModName (is_mod spec) - return (unqual,QualCompls qual) + in (unqual,QualCompls qual) - toCompItem :: Parent -> Module -> T.Text -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem] - toCompItem par m mn n imp' = do - docs <- getDocumentationTryGhc packageState curMod n + toCompItem :: Parent -> Module -> T.Text -> Name -> Maybe (LImportDecl GhcPs) -> [CompItem] + toCompItem par m mn n imp' = + -- docs <- getDocumentationTryGhc packageState curMod n let (mbParent, originName) = case par of NoParent -> (Nothing, nameOccName n) ParentIs n' -> (Just . T.pack $ printName n', nameOccName n) #if !MIN_VERSION_ghc(9,2,0) FldParent n' lbl -> (Just . T.pack $ printName n', maybe (nameOccName n) mkVarOccFS lbl) #endif - tys <- catchSrcErrors (hsc_dflags packageState) "completion" $ do - name' <- lookupName packageState m n - return ( name' >>= safeTyThingType - , guard (isJust mbParent) >> name' >>= safeTyThingForRecord - ) - let (ty, record_ty) = fromRight (Nothing, Nothing) tys - - let recordCompls = case record_ty of - Just (ctxStr, flds) | not (null flds) -> - [mkRecordSnippetCompItem uri mbParent ctxStr flds (ImportedFrom mn) docs imp'] + recordCompls = case par of + ParentIs parent + | isDataConName n + , Just flds <- Map.lookup parent fieldMap + , not (null flds) -> + [mkRecordSnippetCompItem uri mbParent (printOutputable originName) (map (T.pack . unpackFS) flds) (ImportedFrom mn) imp'] _ -> [] - return $ mkNameCompItem uri mbParent originName (ImportedFrom mn) ty Nothing docs imp' - : recordCompls + in mkNameCompItem uri mbParent originName (ImportedFrom mn) Nothing imp' (nameModule_maybe n) + : recordCompls - (unquals,quals) <- getCompls rdrElts + (unquals,quals) = getCompls rdrElts - -- The list of all importable Modules from all packages - moduleNames <- maybe [] (map showModName) <$> envVisibleModuleNames env + -- The list of all importable Modules from all packages + moduleNames = map showModName visibleMods - return $ CC + in CC { allModNamesAsNS = allModNamesAsNS , unqualCompls = unquals , qualCompls = quals @@ -478,9 +438,9 @@ localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsMod TyClD _ x -> let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x) | id <- listify (\(_ :: LIdP GhcPs) -> True) x - , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)] + , let cl = occNameToComKind (rdrNameOcc $ unLoc id)] -- here we only have to look at the outermost type - recordCompls = findRecordCompl uri pm (Local pos) x + recordCompls = findRecordCompl uri (Local pos) x in -- the constructors and snippets will be duplicated here giving the user 2 choices. generalCompls ++ recordCompls @@ -494,27 +454,22 @@ localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsMod ] mkLocalComp pos n ctyp ty = - CI ctyp pn (Local pos) ensureTypeText pn Nothing doc (ctyp `elem` [CiStruct, CiInterface]) Nothing + CI ctyp pn (Local pos) pn ty Nothing (ctyp `elem` [CiStruct, CiInterface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True where - -- when sorting completions, we use the presence of typeText - -- to tell local completions and global completions apart - -- instead of using the empty string here, we should probably introduce a new field... - ensureTypeText = Just $ fromMaybe "" ty + occ = rdrNameOcc $ unLoc n pn = showForSnippet n - doc = SpanDocText (getDocumentation [pm] $ reLoc n) (SpanDocUris Nothing Nothing) -findRecordCompl :: Uri -> ParsedModule -> Provenance -> TyClDecl GhcPs -> [CompItem] -findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result +findRecordCompl :: Uri -> Provenance -> TyClDecl GhcPs -> [CompItem] +findRecordCompl uri mn DataDecl {tcdLName, tcdDataDefn} = result where result = [mkRecordSnippetCompItem uri (Just $ printOutputable $ unLoc tcdLName) - (printOutputable . unLoc $ con_name) field_labels mn doc Nothing + (printOutputable . unLoc $ con_name) field_labels mn Nothing | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn , Just con_details <- [getFlds con_args] , let field_names = concatMap extract con_details , let field_labels = printOutputable <$> field_names , (not . List.null) field_labels ] - doc = SpanDocText (getDocumentation [pmod] $ reLoc tcdLName) (SpanDocUris Nothing Nothing) getFlds conArg = case conArg of RecCon rec -> Just $ unLoc <$> unLoc rec @@ -539,7 +494,7 @@ findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result #endif -- XConDeclField extract _ = [] -findRecordCompl _ _ _ _ = [] +findRecordCompl _ _ _ = [] toggleSnippets :: ClientCapabilities -> CompletionsConfig -> CompletionItem -> CompletionItem toggleSnippets ClientCapabilities {_textDocument} CompletionsConfig{..} = @@ -574,9 +529,10 @@ getCompletions -> ClientCapabilities -> CompletionsConfig -> HM.HashMap T.Text (HashSet.HashSet IdentInfo) + -> Uri -> IO [Scored CompletionItem] getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} - maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do + maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap uri = do let PosPrefixInfo { fullLine, prefixScope, prefixText } = prefixInfo enteredQual = if T.null prefixScope then "" else prefixScope <> "." fullPrefix = enteredQual <> prefixText @@ -641,12 +597,13 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, { compKind = CiField , insertText = label , provenance = DefinedIn recname - , typeText = Nothing , label = label + , typeText = Nothing , isInfix = Nothing - , docs = emptySpanDoc , isTypeCompl = False , additionalTextEdits = Nothing + , nameDetails = Nothing + , isLocalCompletion = False }) -- completions specific to the current context @@ -667,13 +624,14 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, endLoc = upperRange oldPos localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc localBindsToCompItem :: Name -> Maybe Type -> CompItem - localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing + localBindsToCompItem name typ = CI ctyp pn thisModName pn ty Nothing (not $ isValOcc occ) Nothing dets True where occ = nameOccName name - ctyp = occNameToComKind Nothing occ + ctyp = occNameToComKind occ pn = showForSnippet name ty = showForSnippet <$> typ thisModName = Local $ nameSrcSpan name + dets = NameDetails <$> (nameModule_maybe name) <*> pure (nameOccName name) -- When record-dot-syntax completions are available, we return them exclusively. -- They are only available when we write i.e. `myrecord.` with OverloadedRecordDot enabled. @@ -715,7 +673,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, | otherwise -> do -- assumes that nubOrdBy is stable let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls - let compls = (fmap.fmap.fmap) (mkCompl pId ideOpts) uniqueFiltCompls + let compls = (fmap.fmap.fmap) (mkCompl pId ideOpts uri) uniqueFiltCompls pId = lookupCommandProvider plugins (CommandId extendImportCommandId) return $ (fmap.fmap) snd $ @@ -749,15 +707,13 @@ uniqueCompl candidate unique = EQ -> -- preserve completions for duplicate record fields where the only difference is in the type -- remove redundant completions with less type info than the previous - if (typeText candidate == typeText unique && isLocalCompletion unique) + if (isLocalCompletion unique) -- filter global completions when we already have a local one || not(isLocalCompletion candidate) && isLocalCompletion unique then EQ 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 @@ -854,17 +810,8 @@ prefixes = ] -safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text]) -safeTyThingForRecord (AnId _) = Nothing -safeTyThingForRecord (AConLike dc) = - let ctxStr = printOutputable . occName . conLikeName $ dc - field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc - in - Just (ctxStr, field_names) -safeTyThingForRecord _ = Nothing - -mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem -mkRecordSnippetCompItem uri parent ctxStr compl importedFrom docs imp = r +mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> Maybe (LImportDecl GhcPs) -> CompItem +mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r where r = CI { compKind = CiSnippet @@ -873,7 +820,6 @@ mkRecordSnippetCompItem uri parent ctxStr compl importedFrom docs imp = r , typeText = Nothing , label = ctxStr , isInfix = Nothing - , docs = docs , isTypeCompl = False , additionalTextEdits = imp <&> \x -> ExtendImport @@ -883,6 +829,8 @@ mkRecordSnippetCompItem uri parent ctxStr compl importedFrom docs imp = r importQual = getImportQual x, newThing = ctxStr } + , nameDetails = Nothing + , isLocalCompletion = True } placeholder_pairs = zip compl ([1..]::[Int]) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs index be2745d082..393844228b 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} module Development.IDE.Plugin.Completions.Types ( module Development.IDE.Plugin.Completions.Types ) where @@ -11,7 +12,8 @@ import Control.DeepSeq import qualified Data.Map as Map import qualified Data.Text as T -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson +import Data.Aeson.Types import Data.Hashable (Hashable) import Data.Text (Text) import Data.Typeable (Typeable) @@ -22,6 +24,11 @@ import GHC.Generics (Generic) import Ide.Plugin.Properties import Language.LSP.Types (CompletionItemKind (..), Uri) import qualified Language.LSP.Types as J +#if MIN_VERSION_ghc(9,0,0) +import qualified GHC.Types.Name.Occurrence as Occ +#else +import qualified OccName as Occ +#endif -- | Produce completions info for a file type instance RuleResult LocalCompletions = CachedCompletions @@ -83,13 +90,14 @@ data CompItem = CI { compKind :: CompletionItemKind , insertText :: T.Text -- ^ Snippet for the completion , 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. + , typeText :: Maybe T.Text , isInfix :: Maybe Backtick -- ^ Did the completion happen -- in the context of an infix notation. - , docs :: SpanDoc -- ^ Available documentation. , isTypeCompl :: Bool , additionalTextEdits :: Maybe ExtendImport + , nameDetails :: Maybe NameDetails -- ^ For resolving purposes + , isLocalCompletion :: Bool -- ^ Is it from this module? } deriving (Eq, Show) @@ -146,3 +154,59 @@ data PosPrefixInfo = PosPrefixInfo , cursorPos :: !J.Position -- ^ The cursor position } deriving (Show,Eq) + + +-- | This is a JSON serialisable representation of a GHC Name that we include in +-- completion responses so that we can recover the original name corresponding +-- to the completion item. This is used to resolve additional details on demand +-- about the item like its type and documentation. +data NameDetails + = NameDetails Module OccName + deriving (Eq) + +-- NameSpace is abstract so need these +nsJSON :: NameSpace -> Value +nsJSON ns + | isVarNameSpace ns = String "v" + | isDataConNameSpace ns = String "c" + | isTcClsNameSpace ns = String "t" + | isTvNameSpace ns = String "z" + | otherwise = error "namespace not recognized" + +parseNs :: Value -> Parser NameSpace +parseNs (String "v") = pure Occ.varName +parseNs (String "c") = pure dataName +parseNs (String "t") = pure tcClsName +parseNs (String "z") = pure tvName +parseNs _ = mempty + +instance FromJSON NameDetails where + parseJSON v@(Array _) + = do + [modname,modid,namesp,occname] <- parseJSON v + mn <- parseJSON modname + mid <- parseJSON modid + ns <- parseNs namesp + occn <- parseJSON occname + pure $ NameDetails (mkModule (stringToUnit mid) (mkModuleName mn)) (mkOccName ns occn) + parseJSON _ = mempty +instance ToJSON NameDetails where + toJSON (NameDetails mdl occ) = toJSON [toJSON mname,toJSON mid,nsJSON ns,toJSON occs] + where + mname = moduleNameString $ moduleName mdl + mid = unitIdString $ moduleUnitId mdl + ns = occNameSpace occ + occs = occNameString occ +instance Show NameDetails where + show = show . toJSON + +-- | The data that is acutally sent for resolve support +-- We need the URI to be able to reconstruct the GHC environment +-- in the file the completion was triggered in. +data CompletionResolveData = CompletionResolveData + { itemFile :: Uri + , itemNeedsType :: Bool -- ^ Do we need to lookup a type for this item? + , itemName :: NameDetails + } + deriving stock Generic + deriving anyclass (FromJSON, ToJSON) diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 367d756dfc..779a713cf1 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -62,27 +62,28 @@ mkDocMap env rm this_mod = getDocs n map | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist | otherwise = do - doc <- getDocumentationTryGhc env mod n + doc <- getDocumentationTryGhc env n pure $ extendNameEnv map n doc getType n map - | isTcOcc $ occName n = do - kind <- lookupKind env mod n - pure $ maybe map (extendNameEnv map n) kind + | isTcOcc $ occName n + , Nothing <- lookupNameEnv map n + = do kind <- lookupKind env n + pure $ maybe map (extendNameEnv map n) kind | otherwise = pure map names = rights $ S.toList idents idents = M.keysSet rm mod = tcg_mod this_mod -lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) -lookupKind env mod = - fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod +lookupKind :: HscEnv -> Name -> IO (Maybe TyThing) +lookupKind env = + fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env -getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc -getDocumentationTryGhc env mod n = fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env mod [n] +getDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc +getDocumentationTryGhc env n = fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env [n] -getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] -getDocumentationsTryGhc env mod names = do - res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names +getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [SpanDoc] +getDocumentationsTryGhc env names = do + res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names case res of Left _ -> return [] Right res -> zipWithM unwrap res names diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 6b196e5653..9aeee9b4f1 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -264,7 +264,7 @@ initializeResponseTests = withResource acquire release tests where testGroup "initialize response capabilities" [ chk " text doc sync" _textDocumentSync tds , chk " hover" _hoverProvider (Just $ InL True) - , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False)) + , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just True)) , chk "NO signature help" _signatureHelpProvider Nothing , chk " goto definition" _definitionProvider (Just $ InL True) , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) @@ -1517,22 +1517,29 @@ completionTests , testGroup "doc" completionDocTests ] -completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree +completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree completionTest name src pos expected = testSessionWait name $ do docId <- createDoc "A.hs" "haskell" (T.unlines src) _ <- waitForDiagnostics compls <- getCompletions docId pos let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] - liftIO $ do - let emptyToMaybe x = if T.null x then Nothing else Just x - sortOn (Lens.view Lens._1) (take (length expected) compls') @?= - sortOn (Lens.view Lens._1) - [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] - forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do - when expectedSig $ - assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) - when expectedDocs $ - assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) + let emptyToMaybe x = if T.null x then Nothing else Just x + liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?= + sortOn (Lens.view Lens._1) + [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + forM_ (zip compls expected) $ \(item, (_,_,_,expectedSig, expectedDocs, _)) -> do + CompletionItem{..} <- + if expectedSig || expectedDocs + then do + rsp <- request SCompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x + else pure item + when expectedSig $ + liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) + when expectedDocs $ + liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) topLevelCompletionTests :: [TestTree] @@ -1556,14 +1563,14 @@ topLevelCompletionTests = [ [("xxx", CiFunction, "xxx", True, True, Nothing)], completionTest "type" - ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] (Position 0 9) - [("Xxx", CiStruct, "Xxx", False, True, Nothing)], + [("Xzz", CiStruct, "Xzz", False, True, Nothing)], completionTest "class" - ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"] + ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] (Position 0 9) - [("Xxx", CiInterface, "Xxx", False, True, Nothing)], + [("Xzz", CiInterface, "Xzz", False, True, Nothing)], completionTest "records" ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] @@ -1685,7 +1692,7 @@ nonLocalCompletionTests = "variable" ["module A where", "f = hea"] (Position 1 7) - [("head", CiFunction, "head ${1:([a])}", True, True, Nothing)], + [("head", CiFunction, "head", True, True, Nothing)], completionTest "constructor" ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] @@ -1702,13 +1709,13 @@ nonLocalCompletionTests = "qualified" ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] (Position 2 15) - [ ("head", CiFunction, "head ${1:([a])}", True, True, Nothing) + [ ("head", CiFunction, "head", True, True, Nothing) ], completionTest "duplicate import" ["module A where", "import Data.List", "import Data.List", "f = permu"] (Position 3 9) - [ ("permutations", CiFunction, "permutations ${1:([a])}", False, False, Nothing) + [ ("permutations", CiFunction, "permutations", False, False, Nothing) ], completionTest "dont show hidden items" @@ -1726,7 +1733,7 @@ nonLocalCompletionTests = ,"f = BS.read" ] (Position 2 10) - [("readFile", CiFunction, "readFile ${1:FilePath}", True, True, Nothing)] + [("readFile", CiFunction, "readFile", True, True, Nothing)] ], -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls completionTest @@ -1778,7 +1785,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:Bar}", "member ${1:Foo}"], + liftIO $ take 2 compls' @?= ["member"], testSessionWait "maxCompletions" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines @@ -1845,7 +1852,7 @@ packageCompletionTests = _ <- waitForDiagnostics compls <- getCompletions doc (Position 3 13) let duplicate = - find + filter (\case CompletionItem { _insertText = Just "fromList" @@ -1855,7 +1862,7 @@ packageCompletionTests = "GHC.Exts" `T.isInfixOf` d _ -> False ) compls - liftIO $ duplicate @?= Nothing + liftIO $ length duplicate @?= 1 , testSessionWait "non-local before global" $ do -- non local completions are more specific @@ -1873,7 +1880,7 @@ packageCompletionTests = , _label == "fromList" ] liftIO $ take 3 compls' @?= - map Just ["fromList ${1:([Item l])}"] + map Just ["fromList"] ] projectCompletionTests :: [TestTree] @@ -1969,7 +1976,7 @@ completionDocTests = , "bar = fo" ] test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] - , brokenForGhc9 $ testSession "local single line doc without '\\n'" $ do + , testSession "local single line doc without '\\n'" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- |docdoc" @@ -1977,7 +1984,7 @@ completionDocTests = , "bar = fo" ] test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\ndocdoc\n"] - , brokenForGhc9 $ testSession "local multi line doc with '\\n'" $ do + , testSession "local multi line doc with '\\n'" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- | abcabc" @@ -1986,7 +1993,7 @@ completionDocTests = , "bar = fo" ] test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n abcabc\n"] - , brokenForGhc9 $ testSession "local multi line doc without '\\n'" $ do + , testSession "local multi line doc without '\\n'" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- | abcabc" @@ -2033,12 +2040,17 @@ completionDocTests = test doc pos label mn expected = do _ <- waitForDiagnostics compls <- getCompletions doc pos + rcompls <- forM compls $ \item -> do + rsp <- request SCompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x let compls' = [ -- We ignore doc uris since it points to the local path which determined by specific machines case mn of Nothing -> txt Just n -> T.take n txt - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- compls + | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- rcompls , _label == label ] liftIO $ compls' @?= expected diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 1bb96a9fb6..ab355d833d 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -59,7 +59,7 @@ import System.Posix.Signals #endif import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) -import Control.Lens ((^.)) +import Control.Lens ((^.), (.~)) import Data.Aeson hiding (defaultOptions) import Data.Default import Data.Dependent.Map (DMap) @@ -89,6 +89,7 @@ import Language.LSP.Types hiding SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities (ClientCapabilities (ClientCapabilities), TextDocumentClientCapabilities (_codeAction, _documentSymbol)) +import qualified Language.LSP.Types.Lens as J import Language.LSP.Types.Lens as J (HasChildren (children), HasCommand (command), HasContents (contents), @@ -497,6 +498,9 @@ instance PluginMethod Request TextDocumentDocumentSymbol where where uri = msgParams ^. J.textDocument . J.uri +instance PluginMethod Request CompletionItemResolve where + pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) + instance PluginMethod Request TextDocumentCompletion where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) @@ -593,6 +597,18 @@ instance PluginRequestMethod TextDocumentDocumentSymbol where si = SymbolInformation name' (ds ^. kind) Nothing (ds ^. deprecated) loc parent in [si] <> children' +instance PluginRequestMethod CompletionItemResolve where + -- resolving completions can only change the detail, additionalTextEdit or documentation fields + combineResponses _ _ _ _ (x :| xs) = go x xs + where go :: CompletionItem -> [CompletionItem] -> CompletionItem + go !comp [] = comp + go !comp1 (comp2:xs) + = go (comp1 + & J.detail .~ comp1 ^. J.detail <> comp2 ^. J.detail + & J.documentation .~ ((comp1 ^. J.documentation) <|> (comp2 ^. J.documentation)) -- difficult to write generic concatentation for docs + & J.additionalTextEdits .~ comp1 ^. J.additionalTextEdits <> comp2 ^. J.additionalTextEdits) + xs + instance PluginRequestMethod TextDocumentCompletion where combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs where @@ -928,6 +944,7 @@ instance HasTracing WorkspaceSymbolParams where traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query) instance HasTracing CallHierarchyIncomingCallsParams instance HasTracing CallHierarchyOutgoingCallsParams +instance HasTracing CompletionItem -- --------------------------------------------------------------------- diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Machinery.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Machinery.hs index ca082ec65e..278304644e 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Machinery.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Machinery.hs @@ -394,7 +394,7 @@ getTyThing occ = do mvar <- lift $ ExtractM $ lift - $ lookupName (ctx_hscEnv ctx) (ctx_module ctx) + $ lookupName (ctx_hscEnv ctx) $ gre_name elt pure mvar _ -> pure Nothing diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Machinery.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Machinery.hs index ca082ec65e..278304644e 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Machinery.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/Machinery.hs @@ -394,7 +394,7 @@ getTyThing occ = do mvar <- lift $ ExtractM $ lift - $ lookupName (ctx_hscEnv ctx) (ctx_module ctx) + $ lookupName (ctx_hscEnv ctx) $ gre_name elt pure mvar _ -> pure Nothing From ac2b80ed12bdee859a9827c6565fa167a9cefd61 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Fri, 16 Dec 2022 14:37:18 +0530 Subject: [PATCH 2/4] Fixes --- ghcide/src/Development/IDE/Core/Compile.hs | 4 +++- ghcide/src/Development/IDE/Spans/Documentation.hs | 4 +++- ghcide/test/exe/Main.hs | 6 +++--- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 389fbfbf11..dd5f3de106 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -1652,7 +1652,7 @@ lookupName :: HscEnv -> IO (Maybe TyThing) lookupName _ name | Nothing <- nameModule_maybe name = pure Nothing -lookupName hsc_env name = do +lookupName hsc_env name = handle $ do #if MIN_VERSION_ghc(9,2,0) mb_thing <- liftIO $ lookupType hsc_env name #else @@ -1671,6 +1671,8 @@ lookupName hsc_env name = do case res of Util.Succeeded x -> return (Just x) _ -> return Nothing + where + handle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing pathToModuleName :: FilePath -> ModuleName pathToModuleName = mkModuleName . map rep diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 779a713cf1..e3590c5372 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -79,7 +79,9 @@ lookupKind env = fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env getDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc -getDocumentationTryGhc env n = fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env [n] +getDocumentationTryGhc env n = + (fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env [n]) + `catch` (\(_ :: IOEnvFailure) -> pure emptySpanDoc) getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [SpanDoc] getDocumentationsTryGhc env names = do diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 9aeee9b4f1..ca06a32771 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -1983,7 +1983,7 @@ completionDocTests = , "foo = ()" , "bar = fo" ] - test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\ndocdoc\n"] + test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"] , testSession "local multi line doc with '\\n'" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" @@ -1992,7 +1992,7 @@ completionDocTests = , "foo = ()" , "bar = fo" ] - test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n abcabc\n"] + test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"] , testSession "local multi line doc without '\\n'" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" @@ -2002,7 +2002,7 @@ completionDocTests = , "foo = ()" , "bar = fo" ] - test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n abcabc\n\ndef\n"] + test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"] , testSession "extern empty doc" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" From 12bff8ab5f85dfb448d4b315158a236fa7e25365 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Fri, 16 Dec 2022 15:59:45 +0530 Subject: [PATCH 3/4] Fixes --- ghcide/test/exe/Main.hs | 6 +- plugins/hls-refactor-plugin/test/Main.hs | 11 +-- test/functional/Completion.hs | 93 +++++++++++++----------- 3 files changed, 59 insertions(+), 51 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index ca06a32771..ac0b18e490 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -1688,7 +1688,7 @@ localCompletionTests = [ nonLocalCompletionTests :: [TestTree] nonLocalCompletionTests = - [ completionTest + [ brokenForWinGhc $ completionTest "variable" ["module A where", "f = hea"] (Position 1 7) @@ -1699,7 +1699,7 @@ nonLocalCompletionTests = (Position 2 8) [ ("True", CiConstructor, "True", True, True, Nothing) ], - completionTest + brokenForWinGhc $ completionTest "type" ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] (Position 2 8) @@ -1745,6 +1745,8 @@ nonLocalCompletionTests = (Position 0 13) [] ] + where + brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC810, GHC90, GHC92, GHC94]) "Windows has strange things in scope for some reason" otherCompletionTests :: [TestTree] otherCompletionTests = [ diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 5d9baa0c21..9a461c61f5 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -217,19 +217,19 @@ completionTests = "not imported" ["module A where", "import Text.Printf ()", "FormatParse"] (Position 2 10) - "FormatParse {" - ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] + "FormatParse" + ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] , completionCommandTest "parent imported" ["module A where", "import Text.Printf (FormatParse)", "FormatParse"] (Position 2 10) - "FormatParse {" + "FormatParse" ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] , completionNoCommandTest "already imported" ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"] (Position 2 10) - "FormatParse {" + "FormatParse" ] , testGroup "Package completion" [ completionCommandTest @@ -260,7 +260,8 @@ completionCommandTest name src pos wanted expected = testSession name $ do _ <- waitForDiagnostics compls <- skipManyTill anyMessage (getCompletions docId pos) let wantedC = find ( \case - CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x + CompletionItem {_insertText = Just x + ,_command = Just _} -> wanted `T.isPrefixOf` x _ -> False ) compls case wantedC of diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index 7ad0824179..969a736161 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Completion(tests) where +import Control.Monad import Control.Lens hiding ((.=)) import Data.Aeson (object, (.=)) import Data.Foldable (find) @@ -11,6 +12,15 @@ import Language.LSP.Types.Lens hiding (applyEdit) import Test.Hls import Test.Hls.Command +getResolvedCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] +getResolvedCompletions doc pos = do + xs <- getCompletions doc pos + forM xs $ \item -> do + rsp <- request SCompletionItemResolve item + case rsp ^. result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x + tests :: TestTree tests = testGroup "completions" [ testCase "works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -19,34 +29,29 @@ tests = testGroup "completions" [ let te = TextEdit (Range (Position 5 7) (Position 5 24)) "put" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 9) + compls <- getResolvedCompletions doc (Position 5 9) item <- getCompletionByLabel "putStrLn" compls liftIO $ do item ^. label @?= "putStrLn" item ^. kind @?= Just CiFunction - item ^. detail @?= Just ":: String -> IO ()" + item ^. detail @?= Just ":: String -> IO ()\nfrom Prelude" item ^. insertTextFormat @?= Just Snippet - item ^. insertText @?= Just "putStrLn ${1:String}" + item ^. insertText @?= Just "putStrLn" - , ignoreTestBecause "no support for itemCompletion/resolve requests" - $ testCase "itemCompletion/resolve works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + , testCase "itemCompletion/resolve works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" let te = TextEdit (Range (Position 5 7) (Position 5 24)) "put" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 9) + compls <- getResolvedCompletions doc (Position 5 9) item <- getCompletionByLabel "putStrLn" compls - resolvedRes <- request SCompletionItemResolve item - let eResolved = resolvedRes ^. result - case eResolved of - Right resolved -> liftIO $ do - resolved ^. label @?= "putStrLn" - resolved ^. kind @?= Just CiFunction - resolved ^. detail @?= Just "String -> IO ()\nPrelude" - resolved ^. insertTextFormat @?= Just Snippet - resolved ^. insertText @?= Just "putStrLn ${1:String}" - _ -> error $ "Unexpected resolved value: " ++ show eResolved + liftIO $ do + item ^. label @?= "putStrLn" + item ^. kind @?= Just CiFunction + item ^. detail @?= Just ":: String -> IO ()\nfrom Prelude" + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "putStrLn" , testCase "completes imports" $ runSession (hlsCommand <> " --test") fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" @@ -56,7 +61,7 @@ tests = testGroup "completions" [ let te = TextEdit (Range (Position 1 17) (Position 1 26)) "Data.M" _ <- applyEdit doc te - compls <- getCompletions doc (Position 1 23) + compls <- getResolvedCompletions doc (Position 1 23) item <- getCompletionByLabel "Maybe" compls liftIO $ do item ^. label @?= "Maybe" @@ -71,7 +76,7 @@ tests = testGroup "completions" [ let te = TextEdit (Range (Position 2 17) (Position 2 25)) "Data.L" _ <- applyEdit doc te - compls <- getCompletions doc (Position 2 24) + compls <- getResolvedCompletions doc (Position 2 24) item <- getCompletionByLabel "List" compls liftIO $ do item ^. label @?= "List" @@ -81,7 +86,7 @@ tests = testGroup "completions" [ , testCase "completes with no prefix" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" - compls <- getCompletions doc (Position 5 7) + compls <- getResolvedCompletions doc (Position 5 7) liftIO $ assertBool "Expected completions" $ not $ null compls , expectFailIfBeforeGhc92 "record dot syntax is introduced in GHC 9.2" @@ -92,7 +97,7 @@ tests = testGroup "completions" [ let te = TextEdit (Range (Position 25 0) (Position 25 5)) "z = x.a" _ <- applyEdit doc te - compls <- getCompletions doc (Position 25 6) + compls <- getResolvedCompletions doc (Position 25 6) item <- getCompletionByLabel "a" compls liftIO $ do @@ -103,7 +108,7 @@ tests = testGroup "completions" [ let te = TextEdit (Range (Position 27 0) (Position 27 8)) "z2 = x.c.z" _ <- applyEdit doc te - compls <- getCompletions doc (Position 27 9) + compls <- getResolvedCompletions doc (Position 27 9) item <- getCompletionByLabel "z" compls liftIO $ do @@ -117,7 +122,7 @@ tests = testGroup "completions" [ let te = TextEdit (Range (Position 5 0) (Position 5 2)) "acc" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 4) + compls <- getResolvedCompletions doc (Position 5 4) item <- getCompletionByLabel "accessor" compls liftIO $ do item ^. label @?= "accessor" @@ -127,25 +132,25 @@ tests = testGroup "completions" [ let te = TextEdit (Range (Position 5 7) (Position 5 9)) "id" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 9) + compls <- getResolvedCompletions doc (Position 5 9) item <- getCompletionByLabel "id" compls liftIO $ do - item ^. detail @?= Just ":: a -> a" + item ^. detail @?= Just ":: a -> a\nfrom Prelude" , testCase "have implicit foralls with multiple type variables" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" let te = TextEdit (Range (Position 5 7) (Position 5 24)) "flip" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 11) + compls <- getResolvedCompletions doc (Position 5 11) item <- getCompletionByLabel "flip" compls liftIO $ - item ^. detail @?= Just ":: (a -> b -> c) -> b -> a -> c" + item ^. detail @?= Just ":: (a -> b -> c) -> b -> a -> c\nfrom Prelude" , testCase "maxCompletions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" - compls <- getCompletions doc (Position 5 7) + compls <- getResolvedCompletions doc (Position 5 7) liftIO $ length compls @?= maxCompletions def , testCase "import function completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -154,7 +159,7 @@ tests = testGroup "completions" [ let te = TextEdit (Range (Position 0 30) (Position 0 41)) "A" _ <- applyEdit doc te - compls <- getCompletions doc (Position 0 31) + compls <- getResolvedCompletions doc (Position 0 31) item <- getCompletionByLabel "Alternative" compls liftIO $ do item ^. label @?= "Alternative" @@ -167,7 +172,7 @@ tests = testGroup "completions" [ let te = TextEdit (Range (Position 0 39) (Position 0 39)) ", l" _ <- applyEdit doc te - compls <- getCompletions doc (Position 0 42) + compls <- getResolvedCompletions doc (Position 0 42) item <- getCompletionByLabel "liftA" compls liftIO $ do item ^. label @?= "liftA" @@ -177,7 +182,7 @@ tests = testGroup "completions" [ , testCase "completes locally defined associated type family" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "AssociatedTypeFamily.hs" "haskell" - compls <- getCompletions doc (Position 5 20) + compls <- getResolvedCompletions doc (Position 5 20) item <- getCompletionByLabel "Fam" compls liftIO $ do item ^. label @?= "Fam" @@ -195,7 +200,7 @@ snippetTests = testGroup "snippets" [ let te = TextEdit (Range (Position 5 7) (Position 5 24)) "Nothing" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 14) + compls <- getResolvedCompletions doc (Position 5 14) item <- getCompletionByLabel "Nothing" compls liftIO $ do item ^. insertTextFormat @?= Just Snippet @@ -207,13 +212,13 @@ snippetTests = testGroup "snippets" [ let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 11) + compls <- getResolvedCompletions doc (Position 5 11) item <- getCompletionByLabel "foldl" compls liftIO $ do item ^. label @?= "foldl" item ^. kind @?= Just CiFunction item ^. insertTextFormat @?= Just Snippet - item ^. insertText @?= Just "foldl ${1:(b -> a -> b)} ${2:b} ${3:(t a)}" + item ^. insertText @?= Just "foldl" , testCase "work for complex types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" @@ -221,13 +226,13 @@ snippetTests = testGroup "snippets" [ let te = TextEdit (Range (Position 5 7) (Position 5 24)) "mapM" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 11) + compls <- getResolvedCompletions doc (Position 5 11) item <- getCompletionByLabel "mapM" compls liftIO $ do item ^. label @?= "mapM" item ^. kind @?= Just CiFunction item ^. insertTextFormat @?= Just Snippet - item ^. insertText @?= Just "mapM ${1:(a -> m b)} ${2:(t a)}" + item ^. insertText @?= Just "mapM" , testCase "work for infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" @@ -235,7 +240,7 @@ snippetTests = testGroup "snippets" [ let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 18) + compls <- getResolvedCompletions doc (Position 5 18) item <- getCompletionByLabel "filter" compls liftIO $ do item ^. label @?= "filter" @@ -249,7 +254,7 @@ snippetTests = testGroup "snippets" [ let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte`" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 18) + compls <- getResolvedCompletions doc (Position 5 18) item <- getCompletionByLabel "filter" compls liftIO $ do item ^. label @?= "filter" @@ -263,7 +268,7 @@ snippetTests = testGroup "snippets" [ let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 29) + compls <- getResolvedCompletions doc (Position 5 29) item <- getCompletionByLabel "intersperse" compls liftIO $ do item ^. label @?= "intersperse" @@ -277,7 +282,7 @@ snippetTests = testGroup "snippets" [ let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe`" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 29) + compls <- getResolvedCompletions doc (Position 5 29) item <- getCompletionByLabel "intersperse" compls liftIO $ do item ^. label @?= "intersperse" @@ -304,7 +309,7 @@ snippetTests = testGroup "snippets" [ let te = TextEdit (Range (Position 1 0) (Position 1 2)) "MkF" _ <- applyEdit doc te - compls <- getCompletions doc (Position 1 6) + compls <- getResolvedCompletions doc (Position 1 6) item <- case find (\c -> (c ^. label == "MkFoo") && maybe False ("MkFoo {" `T.isPrefixOf`) (c ^. insertText)) compls of Just c -> pure c Nothing -> liftIO . assertFailure $ "Completion with label 'MkFoo' and insertText starting with 'MkFoo {' not found among " <> show compls @@ -317,7 +322,7 @@ snippetTests = testGroup "snippets" [ let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold" _ <- applyEdit doc te - compls <- getCompletions doc (Position 5 11) + compls <- getResolvedCompletions doc (Position 5 11) item <- getCompletionByLabel "foldl" compls liftIO $ do item ^. label @?= "foldl" @@ -342,7 +347,7 @@ contextTests = testGroup "contexts" [ testCase "only provides type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Context.hs" "haskell" - compls <- getCompletions doc (Position 2 17) + compls <- getResolvedCompletions doc (Position 2 17) liftIO $ do compls `shouldContainCompl` "Integer" compls `shouldNotContainCompl` "interact" @@ -350,7 +355,7 @@ contextTests = testGroup "contexts" [ , testCase "only provides value suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Context.hs" "haskell" - compls <- getCompletions doc (Position 3 10) + compls <- getResolvedCompletions doc (Position 3 10) liftIO $ do compls `shouldContainCompl` "abs" compls `shouldNotContainCompl` "Applicative" @@ -358,7 +363,7 @@ contextTests = testGroup "contexts" [ , testCase "completes qualified type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Context.hs" "haskell" - compls <- getCompletions doc (Position 2 26) + compls <- getResolvedCompletions doc (Position 2 26) liftIO $ do compls `shouldNotContainCompl` "forkOn" compls `shouldContainCompl` "MVar" From 2d58fe162cb996de96ee1a504b76655c0d931d1b Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Mon, 19 Dec 2022 02:53:22 +0530 Subject: [PATCH 4/4] Fix flaky call-hierarchy tests Wait for index instead of compliation before making requests as indexing happens in the background in parallel with everything else, so we have to synchronize on the database being ready before making any call hierarchy requests. --- .../hls-call-hierarchy-plugin.cabal | 1 + .../hls-call-hierarchy-plugin/test/Main.hs | 30 ++++++++++++++----- 2 files changed, 23 insertions(+), 8 deletions(-) diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index abd5b17d33..06549aa7b8 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -60,6 +60,7 @@ test-suite tests , filepath , hls-call-hierarchy-plugin , hls-test-utils ^>=1.4 + , ghcide-test-utils , lens , lsp , lsp-test diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index 93ff69b062..08d4b88dbf 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -9,12 +9,13 @@ import Control.Lens (set, (^.)) import Control.Monad.Extra import Data.Aeson import Data.Functor ((<&>)) -import Data.List (sort) +import Data.List (sort, tails) import qualified Data.Map as M import qualified Data.Text as T import Ide.Plugin.CallHierarchy import qualified Language.LSP.Test as Test import qualified Language.LSP.Types.Lens as L +import Development.IDE.Test import System.Directory.Extra import System.FilePath import qualified System.IO.Extra @@ -198,7 +199,7 @@ incomingCallsTests = testCase "xdata unavailable" $ runSessionWithServer plugin testDataDir $ do doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] - waitForKickDone + waitForIndex (testDataDir "A.hs") [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) let expected = [CallHierarchyIncomingCall item (List [mkRange 1 2 1 3])] Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>= @@ -323,7 +324,7 @@ outgoingCallsTests = testCase "xdata unavailable" $ withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] - waitForKickDone + waitForIndex (dir "A.hs") [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) let expected = [CallHierarchyOutgoingCall item (List [mkRange 1 2 1 3])] Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>= @@ -427,7 +428,7 @@ incomingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Asser incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents - waitForKickDone + waitForIndex (dir "A.hs") items <- concatMapM (\((x, y), range) -> Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) <&> map (, range) @@ -447,7 +448,7 @@ incomingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int incomingCallMultiFileTestCase filepath queryX queryY mp = runSessionWithServer plugin testDataDir $ do doc <- openDoc filepath "haskell" - waitForKickDone + waitForIndex (testDataDir filepath) items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do p <- openDoc fp "haskell" waitForKickDone @@ -469,7 +470,7 @@ outgoingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Asser outgoingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents - waitForKickDone + waitForIndex (dir "A.hs") items <- concatMapM (\((x, y), range) -> Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc x y) <&> map (, range) @@ -488,7 +489,7 @@ outgoingCallMultiFileTestCase :: FilePath -> Int -> Int -> M.Map FilePath [((Int outgoingCallMultiFileTestCase filepath queryX queryY mp = runSessionWithServer plugin testDataDir $ do doc <- openDoc filepath "haskell" - waitForKickDone + waitForIndex (testDataDir filepath) items <- fmap concat $ sequence $ M.elems $ M.mapWithKey (\fp pr -> do p <- openDoc fp "haskell" waitForKickDone @@ -509,7 +510,7 @@ oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem) -> Asser oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents - waitForKickDone + waitForIndex (dir "A.hs") Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case [item] -> liftIO $ item @?= expected (doc ^. L.uri) @@ -545,3 +546,16 @@ mkIncomingCallsParam = CallHierarchyIncomingCallsParams Nothing Nothing mkOutgoingCallsParam :: CallHierarchyItem -> CallHierarchyOutgoingCallsParams mkOutgoingCallsParam = CallHierarchyOutgoingCallsParams Nothing Nothing + +-- Wait for a special test message emitted by ghcide when a file is indexed, +-- so that call hierarchy can safely query the database. +waitForIndex :: FilePath -> Session () +waitForIndex fp1 = skipManyTill anyMessage $ void $ referenceReady lenientEquals + where + -- fp1 may be relative, in that case we check that it is a suffix of the + -- filepath from the message + lenientEquals :: FilePath -> Bool + lenientEquals fp2 + | isRelative fp1 = any (equalFilePath fp1) (map (foldr () "") $ tails $ splitDirectories fp2) + | otherwise = equalFilePath fp1 fp2 +