From cbafcf29f4157e86e0522d87bf99cb2aeff1d853 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 13 Jul 2020 15:50:58 +0100 Subject: [PATCH] Performance improvements for GetSpanInfo (#681) * Performance improvements getSpanInfo was naively calling getDocumentations multiple times on the same name. Fixed by deduplicating these calls. getDocumentations is implemented on top of InteractiveEval.getDocs, which does a lot of Ghc setup internally and is very inefficient. Fixed by introducing a batch version of getDocs and batching all the calls in getSpanInfo name | success | samples | startup | setup | experiment | maxResidency ------------- | ------- | ------- | ------- | ----- | ---------- | ------------ edit (before) | True | 10 | 6.94s | 0.00s | 6.57s | 177MB edit (after) | True | 10 | 6.44s | 0.00s | 4.38s | 174MB * More performance improvements Played the deduplication trick on lookupName, which is slow for the same reasons as getDocs. Batching made a smaller difference in my measurements, so did not implement it * Fix redundant constraints * Skip the GHCi code paths for documentation We don't use the interactive module, so there's no reason to go through the GHCi code paths. Moreover, they apparently cause problems with ghc-lib. * Skip the GHCi paths for lookupName * Correctly load the module interface * Compatibility with GHC 8.4 and 8.6 * Fix ghc-lib build --- src/Development/IDE/Core/Compile.hs | 65 ++++++++- src/Development/IDE/GHC/Compat.hs | 1 + src/Development/IDE/GHC/Util.hs | 2 +- .../IDE/Plugin/Completions/Logic.hs | 30 ++-- src/Development/IDE/Spans/Calculate.hs | 136 +++++++++--------- src/Development/IDE/Spans/Common.hs | 6 - src/Development/IDE/Spans/Documentation.hs | 36 +++-- 7 files changed, 166 insertions(+), 110 deletions(-) diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs index b2349b06c..0856901fb 100644 --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -26,6 +26,8 @@ module Development.IDE.Core.Compile , loadDepModule , loadModuleHome , setupFinderCache + , getDocsBatch + , lookupName ) where import Development.IDE.Core.RuleTypes @@ -41,10 +43,10 @@ import Development.IDE.Types.Options import Development.IDE.Types.Location #if MIN_GHC_API_VERSION(8,6,0) -import DynamicLoading (initializePlugins) +import DynamicLoading (initializePlugins) +import LoadIface (loadModuleInterface) #endif -import GHC hiding (parseModule, typecheckModule) import qualified Parser import Lexer #if MIN_GHC_API_VERSION(8,10,0) @@ -53,6 +55,7 @@ import ErrUtils #endif import Finder +import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule) import qualified Development.IDE.GHC.Compat as GHC import qualified Development.IDE.GHC.Compat as Compat import GhcMonad @@ -61,7 +64,7 @@ import qualified HeaderInfo as Hdr import HscMain (hscInteractive, hscSimplify) import MkIface import StringBuffer as SB -import TcRnMonad (initIfaceLoad, tcg_th_coreplugins) +import TcRnMonad (tct_id, TcTyThing(AGlobal, ATcId), initTc, initIfaceLoad, tcg_th_coreplugins) import TcIface (typecheckIface) import TidyPgm @@ -81,6 +84,7 @@ import System.IO.Extra import Control.DeepSeq (rnf) import Control.Exception (evaluate) import Exception (ExceptionMonad) +import TcEnv (tcLookup) -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. @@ -621,3 +625,58 @@ loadInterface session ms sourceMod regen = do | not (mi_used_th x) || SourceUnmodifiedAndStable == sourceMod -> return ([], Just $ HiFileResult ms x) (_reason, _) -> regen + +-- | Non-interactive, batch version of 'InteractiveEval.getDocs'. +-- The interactive paths create problems in ghc-lib builds +--- and leads to fun errors like "Cannot continue after interface file error". +getDocsBatch :: GhcMonad m + => Module -- ^ a moudle where the names are in scope + -> [Name] + -> m [Either String (Maybe HsDocString, Map.Map Int HsDocString)] +getDocsBatch _mod _names = +#if MIN_GHC_API_VERSION(8,6,0) + withSession $ \hsc_env -> liftIO $ do + ((_warns,errs), res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name -> + case nameModule_maybe name of + Nothing -> return (Left $ NameHasNoModule name) + Just mod -> do + ModIface { mi_doc_hdr = mb_doc_hdr + , mi_decl_docs = DeclDocMap dmap + , mi_arg_docs = ArgDocMap amap + } <- loadModuleInterface "getModuleInterface" mod + if isNothing mb_doc_hdr && Map.null dmap && Map.null amap + then pure (Left (NoDocsInIface mod $ compiled name)) + else pure (Right ( Map.lookup name dmap + , Map.findWithDefault Map.empty name amap)) + case res of + Just x -> return $ map (first prettyPrint) x + Nothing -> throwErrors errs + where + throwErrors = liftIO . throwIO . mkSrcErr + compiled n = + -- TODO: Find a more direct indicator. + case nameSrcLoc n of + RealSrcLoc {} -> False + UnhelpfulLoc {} -> True +#else + return [] +#endif + +fakeSpan :: RealSrcSpan +fakeSpan = realSrcLocSpan $ mkRealSrcLoc (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 :: GhcMonad m + => Module -- ^ A module where the Names are in scope + -> Name + -> m (Maybe TyThing) +lookupName mod name = withSession $ \hsc_env -> liftIO $ 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 diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs index fa3c929d7..aaaeba5c1 100644 --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -83,6 +83,7 @@ import GHC hiding ( VarPat, ModLocation, HasSrcSpan, + lookupName, getLoc #if MIN_GHC_API_VERSION(8,6,0) , getConArgs diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs index 15ed5b1ec..55a6dd259 100644 --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -27,7 +27,7 @@ module Development.IDE.GHC.Util( readFileUtf8, hDuplicateTo', setHieDir, - dontWriteHieFiles + dontWriteHieFiles, ) where import Control.Concurrent diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs index edb9fbd8c..dfff882ae 100644 --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -36,6 +36,7 @@ import Coercion import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities import qualified Language.Haskell.LSP.VFS as VFS +import Development.IDE.Core.Compile import Development.IDE.Plugin.Completions.Types import Development.IDE.Spans.Documentation import Development.IDE.GHC.Compat as GHC @@ -230,7 +231,8 @@ cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedC cacheDataProducer packageState tm deps = do let parsedMod = tm_parsed_module tm dflags = hsc_dflags packageState - curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod + curMod = ms_mod $ pm_mod_summary parsedMod + curModName = moduleName curMod Just (_,limports,_,_) = tm_renamed_source tm iDeclToModName :: ImportDecl name -> ModuleName @@ -263,11 +265,11 @@ cacheDataProducer packageState tm deps = do case lookupTypeEnv typeEnv n of Just tt -> case safeTyThingId tt of Just var -> (\x -> ([x],mempty)) <$> varToCompl var - Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n - Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n + Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod curModName n + Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod curModName n getComplsForOne (GRE n _ False prov) = flip foldMapM (map is_decl prov) $ \spec -> do - compItem <- toCompItem (is_mod spec) n + compItem <- toCompItem curMod (is_mod spec) n let unqual | is_qual spec = [] | otherwise = [compItem] @@ -282,21 +284,15 @@ cacheDataProducer packageState tm deps = do varToCompl var = do let typ = Just $ varType var name = Var.varName var - docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name - return $ mkNameCompItem name curMod typ Nothing docs - - toCompItem :: ModuleName -> Name -> IO CompItem - toCompItem mn n = do - docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n --- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi --- and leads to fun errors like "Cannot continue after interface file error". -#ifdef GHC_LIB - let ty = Right Nothing -#else + docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tm_parsed_module tm : deps) name + return $ mkNameCompItem name curModName typ Nothing docs + + toCompItem :: Module -> ModuleName -> Name -> IO CompItem + toCompItem m mn n = do + docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tm_parsed_module tm : deps) n ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do - name' <- lookupName n + name' <- lookupName m n return $ name' >>= safeTyThingType -#endif return $ mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs (unquals,quals) <- getCompls rdrElts diff --git a/src/Development/IDE/Spans/Calculate.hs b/src/Development/IDE/Spans/Calculate.hs index 8221c682d..0797d413c 100644 --- a/src/Development/IDE/Spans/Calculate.hs +++ b/src/Development/IDE/Spans/Calculate.hs @@ -18,26 +18,24 @@ import Data.List import Data.Maybe import DataCon import Desugar -import GHC import GhcMonad import HscTypes import FastString (mkFastString) import OccName import Development.IDE.Types.Location import Development.IDE.Spans.Type -#ifdef GHC_LIB -import Development.IDE.GHC.Error (zeroSpan) -#else import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors) -#endif import Prelude hiding (mod) import TcHsSyn import Var import Development.IDE.Core.Compile import qualified Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import Development.IDE.Spans.Common import Development.IDE.Spans.Documentation +import Data.List.Extra (nubOrd) +import qualified Data.Map.Strict as Map -- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore -- this U ignores that arg in 8.6, but is hidden in 8.4 @@ -56,15 +54,15 @@ getSrcSpanInfos -> IO SpansInfo getSrcSpanInfos env imports tc parsedDeps = evalGhcEnv env $ - getSpanInfo imports (tmrModule tc) parsedDeps + getSpanInfo imports tc parsedDeps -- | Get ALL source spans in the module. getSpanInfo :: GhcMonad m => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports - -> TypecheckedModule + -> TcModuleResult -> [ParsedModule] -> m SpansInfo -getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps = +getSpanInfo mods TcModuleResult{tmrModInfo, tmrModule = tcm@TypecheckedModule{..}} parsedDeps = do let tcs = tm_typechecked_source bs = listifyAllSpans tcs :: [LHsBind GhcTc] es = listifyAllSpans tcs :: [LHsExpr GhcTc] @@ -72,29 +70,52 @@ getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps = ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn] allModules = tm_parsed_module : parsedDeps funBinds = funBindMap tm_parsed_module + thisMod = ms_mod $ pm_mod_summary tm_parsed_module + modIface = hm_iface tmrModInfo -- Load this module in HPT to make its interface documentation available - forM_ (modInfoIface tm_checked_module_info) $ \modIface -> - modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing) + modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing) + + bts <- mapM (getTypeLHsBind funBinds) bs -- binds + ets <- mapM getTypeLHsExpr es -- expressions + pts <- mapM getTypeLPat ps -- patterns + tts <- concat <$> mapM getLHsType ts -- types + + -- Batch extraction of kinds + let typeNames = nubOrd [ n | (Named n, _) <- tts] + kinds <- Map.fromList . zip typeNames <$> mapM (lookupKind thisMod) typeNames + let withKind (Named n, x) = + (Named n, x, join $ Map.lookup n kinds) + withKind (other, x) = + (other, x, Nothing) + tts <- pure $ map withKind tts - bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds - ets <- mapM (getTypeLHsExpr allModules) es -- expressions - pts <- mapM (getTypeLPat allModules) ps -- patterns - tts <- mapM (getLHsType allModules) ts -- types let imports = importInfo mods let exports = getExports tcm - let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts) + let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ tts ++ catMaybes (ets ++ pts) let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs) - return $ SpansInfo (mapMaybe toSpanInfo (sortBy cmp exprs)) - (mapMaybe toSpanInfo (sortBy cmp constraints)) - where cmp (_,a,_,_) (_,b,_,_) + sortedExprs = sortBy cmp exprs + sortedConstraints = sortBy cmp constraints + + -- Batch extraction of Haddocks + let names = nubOrd [ s | (Named s,_,_) <- sortedExprs ++ sortedConstraints] + docs <- Map.fromList . zip names <$> getDocumentationsTryGhc thisMod allModules names + let withDocs (Named n, x, y) = (Named n, x, y, Map.findWithDefault emptySpanDoc n docs) + withDocs (other, x, y) = (other, x, y, emptySpanDoc) + + return $ SpansInfo (mapMaybe (toSpanInfo . withDocs) sortedExprs) + (mapMaybe (toSpanInfo . withDocs) sortedConstraints) + where cmp (_,a,_) (_,b,_) | a `isSubspanOf` b = LT | b `isSubspanOf` a = GT | otherwise = compare (srcSpanStart a) (srcSpanStart b) - addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc)) - constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty, emptySpanDoc) + addEmptyInfo = map (\(a,b) -> (a,b,Nothing)) + constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty) +lookupKind :: GhcMonad m => Module -> Name -> m (Maybe Type) +lookupKind mod = + fmap (either (const Nothing) (safeTyThingType =<<)) . catchSrcErrors "span" . lookupName mod -- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always -- points to the first match) whereas the parsed module has the correct locations. -- Therefore we build up a map from OccName to the corresponding definition in the parsed module @@ -117,27 +138,24 @@ getExports _ = [] ieLNames :: IE pass -> [Located (IdP pass)] ieLNames (IEVar U n ) = [ieLWrappedName n] ieLNames (IEThingAbs U n ) = [ieLWrappedName n] -ieLNames (IEThingAll U n ) = [ieLWrappedName n] -ieLNames (IEThingWith U n _ ns _) = ieLWrappedName n : map ieLWrappedName ns +ieLNames (IEThingAll n ) = [ieLWrappedName n] +ieLNames (IEThingWith n _ ns _) = ieLWrappedName n : map ieLWrappedName ns ieLNames _ = [] -- | Get the name and type of a binding. -getTypeLHsBind :: (GhcMonad m) - => [ParsedModule] - -> OccEnv (HsBind GhcPs) +getTypeLHsBind :: (Monad m) + => OccEnv (HsBind GhcPs) -> LHsBind GhcTc - -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)] -getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid}) + -> m [(SpanSource, SrcSpan, Maybe Type)] +getTypeLHsBind funBinds (L _spn FunBind{fun_id = pid}) | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do let name = getName (unLoc pid) - docs <- getDocumentationTryGhc deps name - return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ] + return [(Named name, getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ] -- In theory this shouldn’t ever fail but if it does, we can at least show the first clause. -getTypeLHsBind deps _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do +getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do let name = getName (unLoc pid) - docs <- getDocumentationTryGhc deps name - return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)] -getTypeLHsBind _ _ _ = return [] + return [(Named name, getLoc pid, Just (varType (unLoc pid)))] +getTypeLHsBind _ _ = return [] -- | Get information about constraints getConstraintsLHsBind :: LHsBind GhcTc @@ -148,19 +166,15 @@ getConstraintsLHsBind _ = [] -- | Get the name and type of an expression. getTypeLHsExpr :: (GhcMonad m) - => [ParsedModule] - -> LHsExpr GhcTc - -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc)) -getTypeLHsExpr deps e = do + => LHsExpr GhcTc + -> m (Maybe (SpanSource, SrcSpan, Maybe Type)) +getTypeLHsExpr e = do hs_env <- getSession (_, mbe) <- liftIO (deSugarExpr hs_env e) case mbe of Just expr -> do let ss = getSpanSource (unLoc e) - docs <- case ss of - Named n -> getDocumentationTryGhc deps n - _ -> return emptySpanDoc - return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs) + return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr)) Nothing -> return Nothing where getSpanSource :: HsExpr GhcTc -> SpanSource @@ -203,43 +217,27 @@ getTypeLHsExpr deps e = do isLitChild e = isLit e -- | Get the name and type of a pattern. -getTypeLPat :: (GhcMonad m) - => [ParsedModule] - -> Pat GhcTc - -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc)) -getTypeLPat deps pat = do +getTypeLPat :: (Monad m) + => Pat GhcTc + -> m (Maybe (SpanSource, SrcSpan, Maybe Type)) +getTypeLPat pat = do let (src, spn) = getSpanSource pat - docs <- case src of - Named n -> getDocumentationTryGhc deps n - _ -> return emptySpanDoc - return $ Just (src, spn, Just (hsPatType pat), docs) + return $ Just (src, spn, Just (hsPatType pat)) where getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan) - getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn) + getSpanSource (VarPat (L spn vid)) = (Named (getName vid), spn) getSpanSource (ConPatOut (L spn (RealDataCon dc)) _ _ _ _ _ _) = (Named (dataConName dc), spn) getSpanSource _ = (NoSource, noSrcSpan) getLHsType - :: GhcMonad m - => [ParsedModule] - -> LHsType GhcRn - -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)] -getLHsType deps (L spn (HsTyVar U _ v)) = do + :: Monad m + => LHsType GhcRn + -> m [(SpanSource, SrcSpan)] +getLHsType (L spn (HsTyVar U _ v)) = do let n = unLoc v - docs <- getDocumentationTryGhc deps n -#ifdef GHC_LIB - let ty = Right Nothing -#else - ty <- catchSrcErrors "completion" $ do - name' <- lookupName n - return $ name' >>= safeTyThingType -#endif - let ty' = case ty of - Right (Just x) -> Just x - _ -> Nothing - pure [(Named n, spn, ty', docs)] -getLHsType _ _ = pure [] + pure [(Named n, spn)] +getLHsType _ = pure [] importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)] -> [(SpanSource, SrcSpan)] diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs index 915b0d396..a1c4d02ee 100644 --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -6,9 +6,7 @@ module Development.IDE.Spans.Common ( , listifyAllSpans , listifyAllSpans' , safeTyThingId -#ifndef GHC_LIB , safeTyThingType -#endif , SpanDoc(..) , emptySpanDoc , spanDocToMarkdown @@ -25,9 +23,7 @@ import Outputable import DynFlags import ConLike import DataCon -#ifndef GHC_LIB import Var -#endif import qualified Documentation.Haddock.Parser as H import qualified Documentation.Haddock.Types as H @@ -47,14 +43,12 @@ listifyAllSpans' :: Typeable a => TypecheckedSource -> [Pat a] listifyAllSpans' tcs = Data.Generics.listify (const True) tcs -#ifndef GHC_LIB -- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs safeTyThingType :: TyThing -> Maybe Type safeTyThingType thing | Just i <- safeTyThingId thing = Just (varType i) safeTyThingType (ATyCon tycon) = Just (tyConKind tycon) safeTyThingType _ = Nothing -#endif safeTyThingId :: TyThing -> Maybe Id safeTyThingId (AnId i) = Just i diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs index b353fd41f..6f80884ae 100644 --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 @@ -7,6 +8,7 @@ module Development.IDE.Spans.Documentation ( getDocumentation , getDocumentationTryGhc + , getDocumentationsTryGhc ) where import Control.Monad @@ -14,31 +16,37 @@ import Data.List.Extra import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T +#if MIN_GHC_API_VERSION(8,6,0) +import Development.IDE.Core.Compile +#endif import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Spans.Common import FastString import SrcLoc (RealLocated) +getDocumentationTryGhc :: GhcMonad m => Module -> [ParsedModule] -> Name -> m SpanDoc +getDocumentationTryGhc mod deps n = head <$> getDocumentationsTryGhc mod deps [n] + +getDocumentationsTryGhc :: GhcMonad m => Module -> [ParsedModule] -> [Name] -> m [SpanDoc] -getDocumentationTryGhc - :: GhcMonad m - => [ParsedModule] - -> Name - -> m SpanDoc --- getDocs goes through the GHCi codepaths which cause problems on ghc-lib. --- See https://github.com/digital-asset/daml/issues/4152 for more details. -#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB) -getDocumentationTryGhc sources name = do - res <- catchSrcErrors "docs" $ getDocs name +-- Interfaces are only generated for GHC >= 8.6. +-- In older versions, interface files do not embed Haddocks anyway +#if MIN_GHC_API_VERSION(8,6,0) +getDocumentationsTryGhc mod sources names = do + res <- catchSrcErrors "docs" $ getDocsBatch mod names case res of - Right (Right (Just docs, _)) -> return $ SpanDocString docs - _ -> return $ SpanDocText $ getDocumentation sources name + Left _ -> return $ map (SpanDocText . getDocumentation sources) names + Right res -> return $ zipWith unwrap res names + where + unwrap (Right (Just docs, _)) _= SpanDocString docs + unwrap _ n = SpanDocText $ getDocumentation sources n #else -getDocumentationTryGhc sources name = do - return $ SpanDocText $ getDocumentation sources name +getDocumentationsTryGhc _ sources names = do + return $ map (SpanDocText . getDocumentation sources) names #endif + getDocumentation :: HasSrcSpan name => [ParsedModule] -- ^ All of the possible modules it could be defined in.