diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 9279abd288..1dead73a6a 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -27,6 +27,7 @@ module Development.IDE.Core.Compile , loadHieFile , loadInterface , loadModulesHome + , getDocsNonInteractive , getDocsBatch , lookupName ,mergeEnvs) where @@ -38,7 +39,6 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util import Development.IDE.GHC.Warnings -import Development.IDE.Spans.Common import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options @@ -78,13 +78,16 @@ import Control.Lens hiding (List) import Control.Monad.Except import Control.Monad.Extra import Control.Monad.Trans.Except -import Data.Bifunctor (first, second) +import Data.Bifunctor (second) import qualified Data.ByteString as BS import qualified Data.DList as DL import Data.IORef +#if !MIN_VERSION_ghc(9,2,1) import qualified Data.IntMap.Strict as IntMap -import Data.List.Extra -import qualified Data.Map.Strict as Map +#endif +import Data.IntMap.Strict (IntMap) +import Data.List.Extra +import qualified Data.Map.Strict as MS import Data.Maybe import qualified Data.Text as T import Data.Time (UTCTime, getCurrentTime) @@ -93,7 +96,6 @@ import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin) --- GHC API imports -- GHC API imports import GHC (GetDocsFailure (..), mgModSummaries, @@ -106,9 +108,8 @@ import Data.Binary import Data.Coerce import Data.Functor import qualified Data.HashMap.Strict as HashMap -import Data.IntMap (IntMap) -import Data.Map (Map) import Data.Tuple.Extra (dupe) +import Data.Either.Extra (maybeToEither) import Data.Unique as Unique import Development.IDE.Core.Tracing (withTrace) import Development.IDE.GHC.Compat.Util (emptyUDFM, plusUDFM_C) @@ -221,9 +222,7 @@ tcRnModule hsc_env keep_lbls pmod = do HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, hpm_annotations = pm_annotations pmod } - let rn_info = case mrn_info of - Just x -> x - Nothing -> error "no renamed info tcRnModule" + let rn_info = fromMaybe (error "no renamed info tcRnModule") mrn_info pure (TcModuleResult pmod rn_info tc_gbl_env splices False) mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult @@ -695,7 +694,7 @@ mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv mergeEnvs env extraModSummaries extraMods envs = do prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs let ims = map (\ms -> Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))) extraModSummaries - ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims + ifrs = zipWith (InstalledFound . ms_location) extraModSummaries ims -- Very important to force this as otherwise the hsc_mod_graph field is not -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get -- this new one, which in turn leads to the EPS referencing the HPT. @@ -712,7 +711,7 @@ mergeEnvs env extraModSummaries extraMods envs = do foldl' (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache $ zip ims ifrs - liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ env{ + liftRnf rwhnf module_graph_nodes `seq` return (loadModulesHome extraMods $ env{ hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs, hsc_FC = newFinderCache, hsc_mod_graph = mkModuleGraph module_graph_nodes @@ -728,7 +727,7 @@ mergeEnvs env extraModSummaries extraMods envs = do -- To work around this, we coerce to the underlying type -- To remove this, I plan to upstream the missing Monoid instance concatFC :: [FinderCache] -> FinderCache - concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult)) + concatFC = unsafeCoerce (mconcat @(MS.Map InstalledModule InstalledFindResult)) withBootSuffix :: HscSource -> ModLocation -> ModLocation withBootSuffix HsBootFile = addBootSuffixLocnOut @@ -829,7 +828,7 @@ parseHeader -> FilePath -- ^ the filename (for source locations) -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported) #if MIN_VERSION_ghc(9,0,1) - -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule)) + -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located HsModule) #else -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) #endif @@ -994,48 +993,95 @@ mkDetailsFromIface session iface linkable = do initIfaceLoad hsc' (typecheckIface iface) return (HomeModInfo iface details linkable) --- | Non-interactive, batch version of 'InteractiveEval.getDocs'. +initTypecheckEnv + :: HscEnv + -> Module + -> TcRn r + -> IO + ( Messages +#if MIN_VERSION_ghc(9,2,1) + DecoratedSDoc +#endif + , Maybe r + ) +initTypecheckEnv hsc_env mod = initTc hsc_env HsSrcFile False mod fakeSpan + where + fakeSpan :: RealSrcSpan + fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "") 1 1 + +-- | Non-interactive handling of the module interface. +-- A non-interactive modification of code from the 'GHC.Runtime.Eval.getDocs'. -- The interactive paths create problems in ghc-lib builds ---- and leads to fun errors like "Cannot continue after interface file error". -getDocsBatch - :: HscEnv - -> Module -- ^ a moudle where the names are in scope - -> [Name] - -> IO [Either String (Maybe HsDocString, IntMap HsDocString)] -getDocsBatch hsc_env _mod _names = do - (msgs, 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 && null amap - then pure (Left (NoDocsInIface mod $ compiled name)) - else pure (Right ( Map.lookup name dmap , -#if !MIN_VERSION_ghc(9,2,0) - IntMap.fromAscList $ Map.toAscList $ +--- and lead to fun errors like "Cannot continue after interface file error". +getDocsNonInteractive' + :: Name + -> IOEnv + (Env TcGblEnv TcLclEnv) + (Name, + Either + GetDocsFailure (Maybe HsDocString, Maybe (IntMap HsDocString))) +getDocsNonInteractive' name = + case nameModule_maybe name of + Nothing -> return (name, Left $ NameHasNoModule name) + Just mod -> do -- in GHC here was an interactive check & handling. + ModIface + { mi_doc_hdr = mb_doc_hdr + , mi_decl_docs = DeclDocMap dmap + , mi_arg_docs = ArgDocMap amap + } + <- loadModuleInterface "getModuleInterface" mod + let + isNameCompiled = + -- comment from GHC: Find a more direct indicator. + case nameSrcLoc name of + RealSrcLoc {} -> False + UnhelpfulLoc {} -> True +#if MIN_VERSION_ghc(9,2,1) + amap' = amap +#else + amap' = MS.map (IntMap.fromAscList . MS.toAscList) amap #endif - Map.findWithDefault mempty name amap)) - case res of - Just x -> return $ map (first $ T.unpack . showGhc) x - Nothing -> throwErrors -#if MIN_VERSION_ghc(9,2,0) - $ Error.getErrorMessages msgs + + pure . (name,) $ + if isNothing mb_doc_hdr && MS.null dmap && MS.null amap' + then Left $ NoDocsInIface mod isNameCompiled + else Right (MS.lookup name dmap, MS.lookup name amap') + +-- | Non-interactive modification of 'GHC.Runtime.Eval.getDocs'. +getDocsNonInteractive + :: HscEnv + -> Module + -> Name + -> IO (Either GHC.ErrorMessages (Name, Either GetDocsFailure (Maybe HsDocString, Maybe (IntMap HsDocString)))) +getDocsNonInteractive hsc_env mod name = + do + let + init = initTypecheckEnv hsc_env mod $ getDocsNonInteractive' name +#if MIN_VERSION_ghc (9,2,1) + (Error.getErrorMessages -> errs, res) <- init #else - $ snd msgs + ((_warns,errs), res) <- init #endif - where - throwErrors = liftIO . throwIO . mkSrcErr - compiled n = - -- TODO: Find a more direct indicator. - case nameSrcLoc n of - RealSrcLoc {} -> False - UnhelpfulLoc {} -> True + pure $ maybeToEither errs res -fakeSpan :: RealSrcSpan -fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "") 1 1 + +-- | Non-interactive, batch version of 'GHC.Runtime.Eval.getDocs'. +getDocsBatch + :: HscEnv + -> Module -- ^ a moudle where the names are in scope + -> [Name] + -> IO (Either GHC.ErrorMessages (MS.Map Name (Either GetDocsFailure (Maybe HsDocString, Maybe (IntMap HsDocString))))) + -- ^ Return a 'Map' of 'Name's to 'Either' (no docs messages) (general doc body & arg docs) +getDocsBatch hsc_env mod names = + do + let + init = initTypecheckEnv hsc_env mod $ MS.fromList <$> traverse getDocsNonInteractive' names +#if MIN_VERSION_ghc (9,2,1) + (Error.getErrorMessages -> errs, res) <- init +#else + ((_warns,errs), res) <- init +#endif + pure $ maybeToEither errs res -- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. -- The interactive paths create problems in ghc-lib builds @@ -1045,11 +1091,11 @@ lookupName :: HscEnv -> Name -> IO (Maybe TyThing) lookupName hsc_env mod name = do - (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do + (_messages, res) <- initTypecheckEnv hsc_env mod $ do tcthing <- tcLookup name case tcthing of AGlobal thing -> return thing - ATcId{tct_id=id} -> return (AnId id) + ATcId{tct_id=id} -> return $ AnId id _ -> panic "tcRnLookupName'" return res diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs index e3a4ecabe2..6db404afdf 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -27,6 +27,8 @@ module Development.IDE.GHC.Compat.Outputable ( mkWarnMsg, mkSrcErr, srcErrorMessages, + Messages, + ErrorMessages ) where @@ -50,7 +52,7 @@ import GHC.Driver.Session import GHC.Driver.Types as HscTypes import GHC.Types.Name.Reader (GlobalRdrEnv) import GHC.Types.SrcLoc -import GHC.Utils.Error as Err hiding (mkWarnMsg) +import GHC.Utils.Error hiding (mkWarnMsg) import qualified GHC.Utils.Error as Err import GHC.Utils.Outputable as Out #else diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index ffa2a25c6e..a075da3244 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -12,13 +12,13 @@ module Development.IDE.Spans.Documentation ( , mkDocMap ) where -import Control.Monad -import Control.Monad.Extra (findM) import Control.Monad.IO.Class +import Control.Monad.Extra (findM) +import Data.Bool (bool) import Data.Either import Data.Foldable import Data.List.Extra -import qualified Data.Map as M +import qualified Data.Map.Strict as MS import Data.Maybe import qualified Data.Set as S import qualified Data.Text as T @@ -31,7 +31,7 @@ import Development.IDE.Spans.Common import System.Directory import System.FilePath -import Language.LSP.Types (filePathToUri, getUri) +import Language.LSP.Types (filePathToUri, getUri) mkDocMap :: HscEnv @@ -45,61 +45,71 @@ mkDocMap env rm this_mod = #else let (_ , DeclDocMap this_docs, _) = extractDocs this_mod #endif - d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names + d <- foldrM getDocs (mkNameEnv $ MS.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names k <- foldrM getType (tcg_type_env this_mod) names pure $ DKMap d k where - getDocs n map - | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist + getDocs n mapToSpanDoc + | maybe True (mod ==) $ nameModule_maybe n = pure mapToSpanDoc -- we already have the docs in this_docs, or they do not exist | otherwise = do doc <- getDocumentationTryGhc env mod n - pure $ extendNameEnv map n doc - getType n map + pure $ extendNameEnv mapToSpanDoc n doc + getType n mapToTyThing | isTcOcc $ occName n = do kind <- lookupKind env mod n - pure $ maybe map (extendNameEnv map n) kind - | otherwise = pure map + pure $ maybe mapToTyThing (extendNameEnv mapToTyThing n) kind + | otherwise = pure mapToTyThing names = rights $ S.toList idents - idents = M.keysSet rm + idents = MS.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 +intoSpanDoc :: HscEnv -> Name -> Either a (Maybe HsDocString, b) -> IO SpanDoc +intoSpanDoc env name a = extractDocString a <$> getSpanDocUris name + where + extractDocString :: Either b1 (Maybe HsDocString, b2) -> SpanDocUris -> SpanDoc + -- 2021-11-17: FIXME: ArgDocs get dropped here - instead propagate them. + extractDocString (Right (Just docs, _)) = SpanDocString docs + extractDocString _ = SpanDocText mempty + + -- | Get the uris to the documentation and source html pages if they exist + getSpanDocUris :: Name -> IO SpanDocUris + getSpanDocUris name = do + (docFu, srcFu) <- + case nameModule_maybe name of + Just mod -> liftIO $ do + let + toUriFileText :: (HscEnv -> Module -> IO (Maybe FilePath)) -> IO (Maybe T.Text) + toUriFileText f = (fmap . fmap) (getUri . filePathToUri) $ f env mod + doc <- toUriFileText lookupDocHtmlForModule + src <- toUriFileText lookupSrcHtmlForModule + return (doc, src) + Nothing -> pure mempty + let + embelishUri :: Functor f => T.Text -> f T.Text -> f T.Text + embelishUri f = fmap (<> "#" <> f <> showNameWithoutUniques name) + + docUri = embelishUri (bool "t:" "v:" $ isValName name) docFu + srcUri = embelishUri mempty srcFu + + return $ SpanDocUris docUri srcUri + getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc -getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] +getDocumentationTryGhc env mod name = do + res <- getDocsNonInteractive env mod name + case res of + Left _ -> pure emptySpanDoc + Right res -> uncurry (intoSpanDoc env) res -getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] +getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO (MS.Map Name SpanDoc) getDocumentationsTryGhc env mod names = do - res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names + res <- getDocsBatch env mod names case res of - Left _ -> return [] - Right res -> zipWithM unwrap res names - where - unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n - unwrap _ n = mkSpanDocText n - - mkSpanDocText name = - SpanDocText [] <$> getUris name - - -- Get the uris to the documentation and source html pages if they exist - getUris name = do - (docFu, srcFu) <- - case nameModule_maybe name of - Just mod -> liftIO $ do - doc <- toFileUriText $ lookupDocHtmlForModule env mod - src <- toFileUriText $ lookupSrcHtmlForModule env mod - return (doc, src) - Nothing -> pure (Nothing, Nothing) - let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu - srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu - selector - | isValName name = "v:" - | otherwise = "t:" - return $ SpanDocUris docUri srcUri - - toFileUriText = (fmap . fmap) (getUri . filePathToUri) + Left _ -> return mempty + Right res -> sequenceA $ MS.mapWithKey (intoSpanDoc env) res getDocumentation :: HasSrcSpan name @@ -171,7 +181,7 @@ getDocumentation sources targetName = fromMaybe [] $ do docHeaders :: [RealLocated AnnotationComment] -> [T.Text] docHeaders = mapMaybe (\(L _ x) -> wrk x) - where + where wrk = \case -- When `Opt_Haddock` is enabled. AnnDocCommentNext s -> Just $ T.pack s