From 981635dce66847483dacafe70a8451a9ba7d9324 Mon Sep 17 00:00:00 2001 From: yoshitsugu Date: Wed, 10 Nov 2021 17:41:41 +0900 Subject: [PATCH 1/8] Skip parsing without haddock for above GHC9.0 --- ghcide/src/Development/IDE/Core/Rules.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 23fa70d3df..7239e6abce 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -218,6 +218,11 @@ getParsedModuleRule = mainParse = getParsedModuleDefinition hsc opt file ms reset_ms pm = pm { pm_mod_summary = ms' } +#if MIN_VERSION_ghc(9,0,1) + -- We no longer need to parse again if GHC version is above 9.0 + -- https://github.com/haskell/haskell-language-server/issues/1892 + res@(_,pmod) <- liftIO $ (fmap.fmap.fmap) reset_ms mainParse +#else -- Parse again (if necessary) to capture Haddock parse errors res@(_,pmod) <- if gopt Opt_Haddock dflags then @@ -245,6 +250,7 @@ getParsedModuleRule = -- This seems to be the correct behaviour because the Haddock flag is added -- by us and not the user, so our IDE shouldn't stop working because of it. _ -> pure (diagsM, res) +#endif -- Add dependencies on included files _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod) pure res @@ -892,12 +898,17 @@ regenerateHiFile sess f ms compNeeded = do -- Embed haddocks in the interface file (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms) +#if MIN_VERSION_ghc(9,0,1) + -- We no longer need to parse again if GHC version is above 9.0 + -- https://github.com/haskell/haskell-language-server/issues/1892 +#else (diags, mb_pm) <- case mb_pm of Just _ -> return (diags, mb_pm) Nothing -> do -- if parsing fails, try parsing again with Haddock turned off (diagsNoHaddock, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm) +#endif case mb_pm of Nothing -> return (diags, Nothing) Just pm -> do From c225c647a05fe966d7bb8cc1245ac32521c51d3a Mon Sep 17 00:00:00 2001 From: yoshitsugu Date: Wed, 10 Nov 2021 18:06:40 +0900 Subject: [PATCH 2/8] Use runtime ghc version check --- ghcide/src/Development/IDE/Core/Rules.hs | 22 +++++++--------------- 1 file changed, 7 insertions(+), 15 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 7239e6abce..ae6b18a2c7 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -218,13 +218,9 @@ getParsedModuleRule = mainParse = getParsedModuleDefinition hsc opt file ms reset_ms pm = pm { pm_mod_summary = ms' } -#if MIN_VERSION_ghc(9,0,1) - -- We no longer need to parse again if GHC version is above 9.0 - -- https://github.com/haskell/haskell-language-server/issues/1892 - res@(_,pmod) <- liftIO $ (fmap.fmap.fmap) reset_ms mainParse -#else -- Parse again (if necessary) to capture Haddock parse errors - res@(_,pmod) <- if gopt Opt_Haddock dflags + -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892 + res@(_,pmod) <- if Compat.ghcVersion >= Compat.GHC90 || gopt Opt_Haddock dflags then liftIO $ (fmap.fmap.fmap) reset_ms mainParse else do @@ -250,7 +246,6 @@ getParsedModuleRule = -- This seems to be the correct behaviour because the Haddock flag is added -- by us and not the user, so our IDE shouldn't stop working because of it. _ -> pure (diagsM, res) -#endif -- Add dependencies on included files _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod) pure res @@ -898,17 +893,14 @@ regenerateHiFile sess f ms compNeeded = do -- Embed haddocks in the interface file (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms) -#if MIN_VERSION_ghc(9,0,1) - -- We no longer need to parse again if GHC version is above 9.0 - -- https://github.com/haskell/haskell-language-server/issues/1892 -#else - (diags, mb_pm) <- case mb_pm of - Just _ -> return (diags, mb_pm) - Nothing -> do + (diags, mb_pm) <- + -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892 + if Compat.ghcVersion >= Compat.GHC90 || isJust mb_pm then do + return (diags, mb_pm) + else do -- if parsing fails, try parsing again with Haddock turned off (diagsNoHaddock, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm) -#endif case mb_pm of Nothing -> return (diags, Nothing) Just pm -> do From 50a50b829d1c4cabcb011b5ef147d7718e1d22db Mon Sep 17 00:00:00 2001 From: yoshitsugu Date: Fri, 12 Nov 2021 15:05:18 +0900 Subject: [PATCH 3/8] Need parse twice in getParsedModuleRule --- ghcide/src/Development/IDE/Core/Rules.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index ae6b18a2c7..a710a7a37e 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -221,6 +221,7 @@ getParsedModuleRule = -- Parse again (if necessary) to capture Haddock parse errors -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892 res@(_,pmod) <- if Compat.ghcVersion >= Compat.GHC90 || gopt Opt_Haddock dflags + res@(_,pmod) <- if gopt Opt_Haddock dflags then liftIO $ (fmap.fmap.fmap) reset_ms mainParse else do From afde4790278f0f5c4786b649fbe5d7cfde3fd0cd Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Wed, 10 Nov 2021 10:42:27 +0000 Subject: [PATCH 4/8] 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 Co-authored-by: Javier Neira --- 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 b2f560e9c3..6bc9e50f32 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 26fcd8554d..cf58bca1ea 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. + + 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 a345e24889..e1a61cd754 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 414f3048ca..510d30ac05 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 700cad4596..e90aa70423 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 ("aell",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 eec662dcb8..14fa2f6a8a 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 da12500f7f..119db3079d 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 ] From 7ce5681b52473a910a20f103957ae025e8f37fb4 Mon Sep 17 00:00:00 2001 From: Javier Neira Date: Wed, 10 Nov 2021 14:19:21 +0100 Subject: [PATCH 5/8] Give unique names to post-jobs (#2337) --- .github/workflows/bench.yml | 2 +- .github/workflows/nix.yml | 2 +- .github/workflows/test.yml | 2 +- ghcide/src/Development/IDE/Core/Rules.hs | 4 ---- 4 files changed, 3 insertions(+), 7 deletions(-) diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 9213a22c2c..ce9a8332a2 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -159,7 +159,7 @@ jobs: ghcide/bench-results/**/*.eventlog ghcide/bench-results/**/*.hp - post_job: + bench_post_job: if: always() runs-on: ubuntu-latest needs: [pre_job, bench_init, bench_example] diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml index 7312cef262..0fad1d2d1d 100644 --- a/.github/workflows/nix.yml +++ b/.github/workflows/nix.yml @@ -107,7 +107,7 @@ jobs: if: ${{ env.HAS_TOKEN == 'true' }} run: nix path-info --json | jq -r '.[].path' | cachix push haskell-language-server - post_job: + nix_post_job: if: always() runs-on: ubuntu-latest needs: [pre_job, develop, build] diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 524b3362d6..3f081e8c8e 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -224,7 +224,7 @@ jobs: name: Test hls-hlint-plugin test suite run: cabal test hls-hlint-plugin --test-options="-j1 --rerun-update" || cabal test hls-hlint-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-hlint-plugin --test-options="-j1 --rerun" - post_job: + test_post_job: if: always() runs-on: ubuntu-latest needs: [pre_job, test] diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index a710a7a37e..939b1ee060 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -217,10 +217,6 @@ getParsedModuleRule = let dflags = ms_hspp_opts ms mainParse = getParsedModuleDefinition hsc opt file ms reset_ms pm = pm { pm_mod_summary = ms' } - - -- Parse again (if necessary) to capture Haddock parse errors - -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892 - res@(_,pmod) <- if Compat.ghcVersion >= Compat.GHC90 || gopt Opt_Haddock dflags res@(_,pmod) <- if gopt Opt_Haddock dflags then liftIO $ (fmap.fmap.fmap) reset_ms mainParse From 5406cf9a1e405d5bb84f7c23ce40f68917795ea2 Mon Sep 17 00:00:00 2001 From: yoshitsugu Date: Fri, 12 Nov 2021 15:13:44 +0900 Subject: [PATCH 6/8] Restore comment --- ghcide/src/Development/IDE/Core/Rules.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 939b1ee060..73d7cf990c 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -217,6 +217,8 @@ getParsedModuleRule = let dflags = ms_hspp_opts ms mainParse = getParsedModuleDefinition hsc opt file ms reset_ms pm = pm { pm_mod_summary = ms' } + + -- Parse again (if necessary) to capture Haddock parse errors res@(_,pmod) <- if gopt Opt_Haddock dflags then liftIO $ (fmap.fmap.fmap) reset_ms mainParse From d7b8e18c4f189458ebfe7224fe5d47bc120af916 Mon Sep 17 00:00:00 2001 From: yoshitsugu Date: Sat, 13 Nov 2021 05:27:03 +0900 Subject: [PATCH 7/8] Parse only with Haddock above GHC90 --- ghcide/src/Development/IDE/Core/Rules.hs | 65 +++++++++++++----------- 1 file changed, 35 insertions(+), 30 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 73d7cf990c..250165014c 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -213,38 +213,43 @@ getParsedModuleRule = opt <- getIdeOptions modify_dflags <- getModifyDynFlags dynFlagsModifyParser let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } - - let dflags = ms_hspp_opts ms - mainParse = getParsedModuleDefinition hsc opt file ms reset_ms pm = pm { pm_mod_summary = ms' } - -- Parse again (if necessary) to capture Haddock parse errors - res@(_,pmod) <- if gopt Opt_Haddock dflags - then - liftIO $ (fmap.fmap.fmap) reset_ms mainParse - else do - let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms) - - -- parse twice, with and without Haddocks, concurrently - -- we cannot ignore Haddock parse errors because files of - -- non-interest are always parsed with Haddocks - -- If we can parse Haddocks, might as well use them - -- - -- HLINT INTEGRATION: might need to save the other parsed module too - ((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse - - -- Merge haddock and regular diagnostics so we can always report haddock - -- parse errors - let diagsM = mergeParseErrorsHaddock diags diagsh - case resh of - Just _ - | HaddockParse <- optHaddockParse opt - -> pure (diagsM, resh) - -- If we fail to parse haddocks, report the haddock diagnostics as well and - -- return the non-haddock parse. - -- This seems to be the correct behaviour because the Haddock flag is added - -- by us and not the user, so our IDE shouldn't stop working because of it. - _ -> pure (diagsM, res) + -- We still parse with Haddocks whether Opt_Haddock is True or False to collect information + -- but we no longer need to parse with and without Haddocks separately for above GHC90. + res@(_,pmod) <- if Compat.ghcVersion >= Compat.GHC90 then + liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file (withOptHaddock ms) + else do + let dflags = ms_hspp_opts ms + mainParse = getParsedModuleDefinition hsc opt file ms + + -- Parse again (if necessary) to capture Haddock parse errors + if gopt Opt_Haddock dflags + then + liftIO $ (fmap.fmap.fmap) reset_ms mainParse + else do + let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms) + + -- parse twice, with and without Haddocks, concurrently + -- we cannot ignore Haddock parse errors because files of + -- non-interest are always parsed with Haddocks + -- If we can parse Haddocks, might as well use them + -- + -- HLINT INTEGRATION: might need to save the other parsed module too + ((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse + + -- Merge haddock and regular diagnostics so we can always report haddock + -- parse errors + let diagsM = mergeParseErrorsHaddock diags diagsh + case resh of + Just _ + | HaddockParse <- optHaddockParse opt + -> pure (diagsM, resh) + -- If we fail to parse haddocks, report the haddock diagnostics as well and + -- return the non-haddock parse. + -- This seems to be the correct behaviour because the Haddock flag is added + -- by us and not the user, so our IDE shouldn't stop working because of it. + _ -> pure (diagsM, res) -- Add dependencies on included files _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod) pure res From 44bdb811b66aaaa985bfe9f1c167984d194566d2 Mon Sep 17 00:00:00 2001 From: yoshitsugu Date: Mon, 15 Nov 2021 09:28:03 +0900 Subject: [PATCH 8/8] Remove obsolete comment --- ghcide/src/Development/IDE/Core/Rules.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 250165014c..d128d7dcd1 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -234,8 +234,6 @@ getParsedModuleRule = -- we cannot ignore Haddock parse errors because files of -- non-interest are always parsed with Haddocks -- If we can parse Haddocks, might as well use them - -- - -- HLINT INTEGRATION: might need to save the other parsed module too ((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse -- Merge haddock and regular diagnostics so we can always report haddock