aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock.hs26
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs19
-rw-r--r--haddock-api/src/Haddock/Interface.hs5
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs9
-rw-r--r--haddock-api/src/Haddock/Options.hs11
5 files changed, 37 insertions, 33 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index cb444844..3543d8e2 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -178,6 +178,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
@@ -195,7 +196,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) $
@@ -205,7 +206,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
@@ -254,9 +255,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
@@ -265,12 +266,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)
@@ -283,7 +284,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
@@ -297,7 +297,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
@@ -342,7 +342,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: " ++)
@@ -373,7 +373,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)
@@ -383,7 +383,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
@@ -403,7 +403,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 "
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 1f55db10..2ef0c61b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -31,6 +31,7 @@ import GHC.Driver.Ppr
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Parser.Annotation (IsUnicodeSyntax(..))
+import GHC.Unit.State
import Data.Char
import Data.List
@@ -46,8 +47,8 @@ prefix = ["-- Hoogle documentation, generated by Haddock"
,""]
-ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
-ppHoogle dflags package version synopsis prologue ifaces odir = do
+ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
+ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do
let -- Since Hoogle is line based, we want to avoid breaking long lines.
dflags' = dflags{ pprCols = maxBound }
filename = package ++ ".txt"
@@ -56,16 +57,16 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do
["@package " ++ package] ++
["@version " ++ showVersion version
| not (null (versionBranch version)) ] ++
- concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+ concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i]
createDirectoryIfMissing True odir
writeUtf8File (odir </> filename) (unlines contents)
-ppModule :: DynFlags -> Interface -> [String]
-ppModule dflags iface =
+ppModule :: DynFlags -> UnitState -> Interface -> [String]
+ppModule dflags unit_state iface =
"" : ppDocumentation dflags (ifaceDoc iface) ++
["module " ++ moduleString (ifaceMod iface)] ++
concatMap (ppExport dflags) (ifaceExportItems iface) ++
- concatMap (ppInstance dflags) (ifaceInstances iface)
+ concatMap (ppInstance dflags unit_state) (ifaceInstances iface)
---------------------------------------------------------------------
@@ -204,9 +205,9 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info })
ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }
_ -> decl
-ppInstance :: DynFlags -> ClsInst -> [String]
-ppInstance dflags x =
- [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls]
+ppInstance :: DynFlags -> UnitState -> ClsInst -> [String]
+ppInstance dflags unit_state x =
+ [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls]
where
-- As per #168, we don't want safety information about the class
-- in Hoogle output. The easiest way to achieve this is to set the
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 583cacf8..be9bd09a 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -159,10 +159,11 @@ processModule verbosity modsum flags modMap instIfaceMap = do
IsBoot ->
return Nothing
NotBoot -> do
+ unit_state <- hsc_units <$> getSession
out verbosity verbose "Creating interface..."
(interface, msgs) <- {-# SCC createIterface #-}
withTimingD "createInterface" (const ()) $ do
- runWriterGhc $ createInterface tm flags modMap instIfaceMap
+ runWriterGhc $ createInterface tm unit_state flags modMap instIfaceMap
-- We need to keep track of which modules were somehow in scope so that when
-- Haddock later looks for instances, it also looks in these modules too.
@@ -170,7 +171,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do
-- See https://github.com/haskell/haddock/issues/469.
hsc_env <- getSession
let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
- home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+ home_unit = hsc_home_unit hsc_env
!mods = mkModuleSet [ nameModule name
| gre <- globalRdrEnvElts new_rdr_env
, let name = gre_name gre
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 8bc8d306..7ef64a94 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -47,6 +47,7 @@ import GHC.Types.SourceFile
import GHC.Core.ConLike (ConLike(..))
import GHC
import GHC.Driver.Ppr
+import GHC.Driver.Env
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
@@ -67,11 +68,12 @@ import GHC.Unit.Module.Warnings
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the 'IfaceMap'.
createInterface :: TypecheckedModule
+ -> UnitState
-> [Flag] -- Boolean flags
-> IfaceMap -- Locally processed modules
-> InstIfaceMap -- External, already installed interfaces
-> ErrMsgGhc Interface
-createInterface tm flags modMap instIfaceMap = do
+createInterface tm unit_state flags modMap instIfaceMap = do
let ms = pm_mod_summary . tm_parsed_module $ tm
mi = moduleInfo tm
@@ -84,7 +86,7 @@ createInterface tm flags modMap instIfaceMap = do
!instances = modInfoInstances mi
!fam_instances = md_fam_insts md
!exportedNames = modInfoExportsWithSelectors mi
- (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl)
+ (pkgNameFS, _) = modulePackageInfo unit_state flags (Just mdl)
pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
(TcGblEnv { tcg_rdr_env = gre
@@ -164,8 +166,7 @@ createInterface tm flags modMap instIfaceMap = do
| otherwise = exportItems
!prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
- let !aliases =
- mkAliasMap (unitState dflags) $ tm_renamed_source tm
+ let !aliases = mkAliasMap unit_state $ tm_renamed_source tm
modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 5c9bf448..eda40935 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -45,7 +45,8 @@ import Data.Version
import Control.Applicative
import Distribution.Verbosity
import GHC.Data.FastString
-import GHC ( DynFlags, Module, moduleUnit, unitState )
+import GHC ( DynFlags, Module, moduleUnit )
+import GHC.Unit.State
import Haddock.Types
import Haddock.Utils
import GHC.Unit.State
@@ -370,16 +371,16 @@ optLast xs = Just (last xs)
--
-- The @--package-name@ and @--package-version@ Haddock flags allow the user to
-- specify this information manually and it is returned here if present.
-modulePackageInfo :: DynFlags
+modulePackageInfo :: UnitState
-> [Flag] -- ^ Haddock flags are checked as they may contain
-- the package name or version provided by the user
-- which we prioritise
-> Maybe Module
-> (Maybe PackageName, Maybe Data.Version.Version)
-modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing)
-modulePackageInfo dflags flags (Just modu) =
+modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing)
+modulePackageInfo unit_state flags (Just modu) =
( optPackageName flags <|> fmap unitPackageName pkgDb
, optPackageVersion flags <|> fmap unitPackageVersion pkgDb
)
where
- pkgDb = lookupUnit (unitState dflags) (moduleUnit modu)
+ pkgDb = lookupUnit unit_state (moduleUnit modu)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 05:31:49 +0000