aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock.hs')
-rw-r--r--haddock-api/src/Haddock.hs40
1 files changed, 23 insertions, 17 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 8dfee5bc..2b6e2d57 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -70,6 +70,7 @@ import GHC hiding (verbosity)
import GHC.Settings.Config
import GHC.Driver.Session hiding (projectVersion, verbosity)
import GHC.Utils.Outputable (defaultUserStyle, withPprStyle)
+import GHC.Driver.Env
import GHC.Utils.Error
import GHC.Unit
import GHC.Utils.Panic (handleGhcException)
@@ -152,12 +153,17 @@ haddockWithGhc ghc args = handleTopExceptions $ do
sinceQual <- rightOrThrowE (sinceQualification flags)
-- inject dynamic-too into flags before we proceed
- flags' <- ghc flags $ do
+ flags'' <- ghc flags $ do
df <- getDynFlags
case lookup "GHC Dynamic" (compilerInfo df) of
Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
_ -> return flags
+ flags' <- pure $ case optParCount flags'' of
+ Nothing -> flags''
+ Just Nothing -> Flag_OptGhc "-j" : flags''
+ Just (Just n) -> Flag_OptGhc ("-j" ++ show n) : flags''
+
-- bypass the interface version check
let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
@@ -179,6 +185,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
ghc flags' $ withDir $ do
dflags <- getDynFlags
+ unit_state <- hsc_units <$> getSession
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
@@ -196,7 +203,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
}
-- Render the interfaces.
- liftIO $ renderStep dflags flags sinceQual qual packages ifaces
+ liftIO $ renderStep dflags unit_state flags sinceQual qual packages ifaces
else do
when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
@@ -206,7 +213,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
- liftIO $ renderStep dflags flags sinceQual qual packages []
+ liftIO $ renderStep dflags unit_state flags sinceQual qual packages []
-- | Run the GHC action using a temporary output directory
withTempOutputDir :: Ghc a -> Ghc a
@@ -255,9 +262,9 @@ readPackagesAndProcessModules flags files = do
return (packages, ifaces, homeLinks)
-renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption
+renderStep :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption
-> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep dflags flags sinceQual nameQual pkgs interfaces = do
+renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do
updateHTMLXRefs pkgs
let
ifaceFiles = map snd pkgs
@@ -266,12 +273,12 @@ renderStep dflags flags sinceQual nameQual pkgs interfaces = do
((_, Just path), ifile) <- pkgs
iface <- ifInstalledIfaces ifile
return (instMod iface, path)
- render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap
+ render dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
-- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface]
+render :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
-> [InstalledInterface] -> Map Module FilePath -> IO ()
-render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
+render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
let
title = fromMaybe "" (optTitle flags)
@@ -284,7 +291,6 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
opt_latex_style = optLaTeXStyle flags
opt_source_css = optSourceCssFile flags
opt_mathjax = optMathjax flags
- pkgs = unitState dflags
dflags'
| unicode = gopt_set dflags Opt_PrintUnicodeSyntax
| otherwise = dflags
@@ -298,7 +304,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
pkgMod = fmap ifaceMod (listToMaybe ifaces)
pkgKey = fmap moduleUnit pkgMod
pkgStr = fmap unitString pkgKey
- pkgNameVer = modulePackageInfo dflags flags pkgMod
+ pkgNameVer = modulePackageInfo unit_state flags pkgMod
pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer)
sincePkg = case sinceQual of
External -> pkgName
@@ -343,7 +349,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
-- records the *wired in* identity base. So untranslate it
-- so that we can service the request.
unwire :: Module -> Module
- unwire m = m { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) }
+ unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) }
reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do
let warn = hPutStrLn stderr . ("Warning: " ++)
@@ -374,7 +380,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
when (Flag_GenContents `elem` flags) $ do
withTiming dflags' "ppHtmlContents" (const ()) $ do
_ <- {-# SCC ppHtmlContents #-}
- ppHtmlContents pkgs odir title pkgStr
+ ppHtmlContents unit_state odir title pkgStr
themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
allVisibleIfaces True prologue pretty
sincePkg (makeContentsQual qual)
@@ -384,7 +390,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
when (Flag_Html `elem` flags) $ do
withTiming dflags' "ppHtml" (const ()) $ do
_ <- {-# SCC ppHtml #-}
- ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir
+ ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir
prologue
themes opt_mathjax sourceUrls' opt_wiki_urls
opt_contents_url opt_index_url unicode sincePkg qual
@@ -404,7 +410,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
pkgVer =
fromMaybe (makeVersion []) mpkgVer
- in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
+ in ppHoogle dflags' unit_state pkgNameStr pkgVer title (fmap _doc prologue)
visibleIfaces odir
_ -> putStrLn . unlines $
[ "haddock: Unable to find a package providing module "
@@ -494,9 +500,9 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock]
| otherwise = [Opt_Haddock]
dynflags' = (foldl' gopt_set dynflags extra_opts)
- { hscTarget = HscNothing
- , ghcMode = CompManager
- , ghcLink = NoLink
+ { backend = NoBackend
+ , ghcMode = CompManager
+ , ghcLink = NoLink
}
flags' = filterRtsFlags flags
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 01:33:29 +0000