[Git][ghc/ghc][master] haddock: Only fetch supported languages and extensions once per Interface list
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Jul 12 15:47:50 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
86b8ecee by Hécate Kleidukos at 2024-07-12T11:46:27-04:00
haddock: Only fetch supported languages and extensions once per Interface list
This reduces the number of operations done on each Interface, because
supported languages and extensions are determined from architecture and
operating system of the build host. This information remains stable
across Interfaces, and as such doesn not need to be recovered for each
Interface.
- - - - -
3 changed files:
- utils/haddock/haddock-api/src/Haddock.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
Changes:
=====================================
utils/haddock/haddock-api/src/Haddock.hs
=====================================
@@ -82,7 +82,7 @@ import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Options
import Haddock.Utils
-import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir)
+import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir, getSupportedLanguagesAndExtensions)
--------------------------------------------------------------------------------
-- * Exception handling
@@ -228,6 +228,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
, piPackageVersion =
fromMaybe (makeVersion []) (optPackageVersion flags)
}
+ languagesAndExtensions = getSupportedLanguagesAndExtensions ifaces
-- Dump an "interface file" (.haddock file), if requested.
forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do
@@ -238,7 +239,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
}
-- Render the interfaces.
- liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages ifaces
+ liftIO $ renderStep dflags languagesAndExtensions parserOpts logger unit_state flags sinceQual qual packages ifaces
-- If we were not given any input files, error if documentation was
-- requested
@@ -251,7 +252,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
- liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages []
+ liftIO $ renderStep dflags [] parserOpts logger unit_state flags sinceQual qual packages []
-- | Run the GHC action using a temporary output directory
withTempOutputDir :: Ghc a -> Ghc a
@@ -305,6 +306,8 @@ readPackagesAndProcessModules flags files = do
renderStep
:: DynFlags
+ -> [String]
+ -- ^ Supported languages and extensions based on architecture and OS
-> ParserOpts
-> Logger
-> UnitState
@@ -314,7 +317,7 @@ renderStep
-> [(DocPaths, Visibility, FilePath, InterfaceFile)]
-> [Interface]
-> IO ()
-renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs interfaces = do
+renderStep dflags languagesAndExtensions parserOpts logger unit_state flags sinceQual nameQual pkgs interfaces = do
updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) ->
( case baseUrl flags of
Nothing -> docPathsHtml docPath
@@ -330,7 +333,7 @@ renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs int
(DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs
iface <- ifInstalledIfaces ifile
return (instMod iface, path)
- render dflags parserOpts logger unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
+ render dflags languagesAndExtensions parserOpts logger unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
where
-- get package name from unit-id
packageName :: Unit -> String
@@ -342,6 +345,8 @@ renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs int
-- | Render the interfaces with whatever backend is specified in the flags.
render
:: DynFlags
+ -> [String]
+ -- ^ Supported languages and extensions based on architecture and OS
-> ParserOpts
-> Logger
-> UnitState
@@ -352,7 +357,7 @@ render
-> [(FilePath, PackageInterfaces)]
-> Map Module FilePath
-> IO ()
-render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages extSrcMap = do
+render dflags languagesAndExtensions parserOpts logger unit_state flags sinceQual qual ifaces packages extSrcMap = do
let
packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty)
$ optPackageName flags
@@ -554,7 +559,7 @@ render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages
when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do
withTiming logger "ppHyperlinkedSource" (const ()) $ do
_ <- {-# SCC ppHyperlinkedSource #-}
- ppHyperlinkedSource (verbosity flags) (isJust (optOneShot flags)) odir libDir opt_source_css pretty srcMap ifaces
+ ppHyperlinkedSource (verbosity flags) (isJust (optOneShot flags)) languagesAndExtensions odir libDir opt_source_css pretty srcMap ifaces
return ()
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
=====================================
@@ -12,13 +12,12 @@ import Control.Monad (unless)
import Data.Map as M
import Data.Maybe
import GHC.Data.FastString (mkFastString)
-import GHC.Platform
import GHC.Driver.Config.Diagnostic (initDiagOpts)
-import GHC.Driver.Session (supportedLanguagesAndExtensions, safeImportsOn)
-import GHC.Parser.Lexer as Lexer
import qualified GHC.Driver.DynFlags as DynFlags
+import GHC.Driver.Session (safeImportsOn)
import GHC.Iface.Ext.Binary (hie_file_result, readHieFile)
import GHC.Iface.Ext.Types (HieAST (..), HieASTs (..), HieFile (..), SourcedNodeInfo (..), pattern HiePath)
+import GHC.Parser.Lexer as Lexer
import GHC.Types.SrcLoc (mkRealSrcLoc, realSrcLocSpan, srcSpanFile)
import GHC.Unit.Module (Module, moduleName)
import qualified GHC.Utils.Outputable as Outputable
@@ -43,6 +42,8 @@ ppHyperlinkedSource
:: Verbosity
-> Bool
-- ^ In one-shot mode
+ -> [String]
+ -- ^ Supported languages and extensions based on architecture and OS
-> FilePath
-- ^ Output directory
-> FilePath
@@ -56,21 +57,29 @@ ppHyperlinkedSource
-> [Interface]
-- ^ Interfaces for which we create source
-> IO ()
-ppHyperlinkedSource verbosity isOneShot outdir libdir mstyle pretty srcs' ifaces = do
+ppHyperlinkedSource verbosity isOneShot languagesAndExtensions outdir libdir mstyle pretty srcs' ifaces = do
createDirectoryIfMissing True srcdir
unless isOneShot $ do
let cssFile = fromMaybe (defaultCssFile libdir) mstyle
copyFile cssFile $ srcdir </> srcCssFile
copyFile (libdir </> "html" </> highlightScript) $
srcdir </> highlightScript
- mapM_ (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces
+ mapM_ (ppHyperlinkedModuleSource verbosity languagesAndExtensions srcdir pretty srcs) ifaces
where
srcdir = outdir </> hypSrcDir
srcs = (srcs', M.mapKeys moduleName srcs')
-- | Generate hyperlinked source for particular interface.
-ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interface -> IO ()
-ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
+ppHyperlinkedModuleSource
+ :: Verbosity
+ -> [String]
+ -- ^ Supported languages and extensions based on architecture and OS
+ -> FilePath
+ -> Bool
+ -> SrcMaps
+ -> Interface
+ -> IO ()
+ppHyperlinkedModuleSource verbosity languagesAndExtensions srcdir pretty srcs iface = do
-- Parse the GHC-produced HIE file
nc <- freshNameCache
HieFile
@@ -114,13 +123,12 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
writeUtf8File path . renderToString pretty . render' fullAst $ tokens
where
dflags = ifaceDynFlags iface
- arch_os = platformArchOS (dflags.targetPlatform)
sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle
parserOpts =
Lexer.mkParserOpts
(dflags.extensionFlags)
(initDiagOpts dflags)
- (supportedLanguagesAndExtensions arch_os)
+ languagesAndExtensions
(safeImportsOn dflags)
False -- lex Haddocks as comment tokens
True -- produce comment tokens
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -36,7 +36,7 @@ import qualified Data.ByteString.Internal as BS
import Data.Char (isSpace)
import Data.Foldable (toList)
import qualified Data.List as List
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set
import GHC
@@ -49,6 +49,7 @@ import GHC.Data.StringBuffer (StringBuffer)
import qualified GHC.Data.StringBuffer as S
import GHC.Driver.Session
import GHC.HsToCore.Docs hiding (sigNameNoLoc)
+import GHC.Platform (Platform (..))
import GHC.Types.Name
import GHC.Types.SrcLoc (advanceSrcLoc)
import GHC.Types.Var
@@ -66,7 +67,7 @@ import GHC.Utils.Outputable (Outputable, SDocContext, ppr)
import qualified GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic (panic)
-import Haddock.Types (DocName, DocNameI, XRecCond)
+import Haddock.Types (DocName, DocNameI, Interface (..), XRecCond)
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
@@ -629,6 +630,14 @@ setOutputDir dir dynFlags =
, dumpDir = Just dir
}
+getSupportedLanguagesAndExtensions
+ :: [Interface]
+ -> [String]
+getSupportedLanguagesAndExtensions [] = []
+getSupportedLanguagesAndExtensions (iface : _) = do
+ let dflags = ifaceDynFlags iface
+ in supportedLanguagesAndExtensions dflags.targetPlatform.platformArchOS
+
-------------------------------------------------------------------------------
-- * 'StringBuffer' and 'ByteString'
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86b8ecee8fcf273fbc7ca5ffabc24b43c070849b
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86b8ecee8fcf273fbc7ca5ffabc24b43c070849b
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240712/4168a08c/attachment-0001.html>
More information about the ghc-commits
mailing list