Commits (2)
......@@ -282,6 +282,7 @@ 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
......@@ -340,7 +341,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 dflags (moduleUnit m) }
unwire m = m { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) }
reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do
let warn = hPutStrLn stderr . ("Warning: " ++)
......@@ -371,7 +372,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
when (Flag_GenContents `elem` flags) $ do
withTiming dflags' "ppHtmlContents" (const ()) $ do
_ <- {-# SCC ppHtmlContents #-}
ppHtmlContents dflags' odir title pkgStr
ppHtmlContents pkgs odir title pkgStr
themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
allVisibleIfaces True prologue pretty
sincePkg (makeContentsQual qual)
......@@ -381,7 +382,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
when (Flag_Html `elem` flags) $ do
withTiming dflags' "ppHtml" (const ()) $ do
_ <- {-# SCC ppHtml #-}
ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir
ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir
prologue
themes opt_mathjax sourceUrls' opt_wiki_urls
opt_contents_url opt_index_url unicode sincePkg qual
......
......@@ -46,7 +46,7 @@ parse dflags fpath bs = case unP (go False []) initState of
start = mkRealSrcLoc (mkFastString fpath) 1 1
pflags = mkParserFlags' (warningFlags dflags)
(extensionFlags dflags)
(thisPackage dflags)
(homeUnitId dflags)
(safeImportsOn dflags)
False -- lex Haddocks as comment tokens
True -- produce comment tokens
......
......@@ -52,12 +52,13 @@ import Data.Ord ( comparing )
import GHC.Driver.Session (Language(..))
import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )
import GHC.Types.Name
import GHC.Unit.State
--------------------------------------------------------------------------------
-- * Generating HTML documentation
--------------------------------------------------------------------------------
ppHtml :: DynFlags
ppHtml :: UnitState
-> String -- ^ Title
-> Maybe String -- ^ Package
-> [Interface]
......@@ -77,7 +78,7 @@ ppHtml :: DynFlags
-> Bool -- ^ Also write Quickjump index
-> IO ()
ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue
themes maybe_mathjax_url maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url unicode
pkg qual debug withQuickjump = do
......@@ -86,7 +87,7 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
visible i = OptHide `notElem` ifaceOptions i
when (isNothing maybe_contents_url) $
ppHtmlContents dflags odir doctitle maybe_package
ppHtmlContents state odir doctitle maybe_package
themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url
(map toInstalledIface visible_ifaces ++ reexported_ifaces)
False -- we don't want to display the packages in a single-package contents
......@@ -258,7 +259,7 @@ moduleInfo iface =
ppHtmlContents
:: DynFlags
:: UnitState
-> FilePath
-> String
-> Maybe String
......@@ -272,14 +273,14 @@ ppHtmlContents
-> Maybe Package -- ^ Current package
-> Qualification -- ^ How to qualify names
-> IO ()
ppHtmlContents dflags odir doctitle _maybe_package
ppHtmlContents state odir doctitle _maybe_package
themes mathjax_url maybe_index_url
maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do
let tree = mkModuleTree dflags showPkgs
let tree = mkModuleTree state showPkgs
[(instMod iface, toInstalledDescription iface)
| iface <- ifaces
, not (instIsSig iface)]
sig_tree = mkModuleTree dflags showPkgs
sig_tree = mkModuleTree state showPkgs
[(instMod iface, toInstalledDescription iface)
| iface <- ifaces
, instIsSig iface]
......
......@@ -167,7 +167,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
this_pkg = thisPackage (hsc_dflags hsc_env)
this_pkg = homeUnit (hsc_dflags hsc_env)
!mods = mkModuleSet [ nameModule name
| gre <- globalRdrEnvElts new_rdr_env
, let name = gre_name gre
......
......@@ -48,7 +48,7 @@ import GHC.Driver.Types
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Unit.State ( lookupModuleInAllPackages, PackageName(..) )
import GHC.Unit.State
import GHC.Data.Bag
import GHC.Types.Name.Reader
import GHC.Tc.Types
......@@ -159,7 +159,7 @@ createInterface tm flags modMap instIfaceMap = do
!prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
let !aliases =
mkAliasMap dflags $ tm_renamed_source tm
mkAliasMap (unitState dflags) $ tm_renamed_source tm
modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
......@@ -197,8 +197,8 @@ createInterface tm flags modMap instIfaceMap = do
-- create a mapping from the module identity of M, to an alias N
-- (if there are multiple aliases, we pick the last one.) This
-- will go in 'ifaceModuleAliases'.
mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
mkAliasMap dflags mRenamedSource =
mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName
mkAliasMap state mRenamedSource =
case mRenamedSource of
Nothing -> M.empty
Just (_,impDecls,_,_) ->
......@@ -206,7 +206,7 @@ mkAliasMap dflags mRenamedSource =
mapMaybe (\(SrcLoc.L _ impDecl) -> do
SrcLoc.L _ alias <- ideclAs impDecl
return $
(lookupModuleDyn dflags
(lookupModuleDyn state
-- TODO: This is supremely dodgy, because in general the
-- UnitId isn't going to look anything like the package
-- qualifier (even with old versions of GHC, the
......@@ -265,13 +265,13 @@ unrestrictedModuleImports idecls =
-- Similar to GHC.lookupModule
-- ezyang: Not really...
lookupModuleDyn ::
DynFlags -> Maybe Unit -> ModuleName -> Module
UnitState -> Maybe Unit -> ModuleName -> Module
lookupModuleDyn _ (Just pkgId) mdlName =
Module.mkModule pkgId mdlName
lookupModuleDyn dflags Nothing mdlName =
case lookupModuleInAllPackages dflags mdlName of
lookupModuleDyn state Nothing mdlName =
case lookupModuleInAllUnits state mdlName of
(m,_):_ -> m
[] -> Module.mkModule Module.mainUnitId mdlName
[] -> Module.mkModule Module.mainUnit mdlName
-------------------------------------------------------------------------------
......@@ -835,7 +835,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
Nothing -> return ([], (noDocForDecl, availNoDocs avail))
-- TODO: If we try harder, we might be able to find
-- a Haddock! Look in the Haddocks for each thing in
-- requirementContext (pkgState)
-- requirementContext (unitState)
Just decl -> return ([decl], (noDocForDecl, availNoDocs avail))
| otherwise ->
return ([], (noDocForDecl, availNoDocs avail))
......@@ -966,8 +966,7 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
"documentation for exported module: " ++ pretty dflags expMod]
return []
where
m = mkModule unitId expMod -- Identity module!
unitId = moduleUnit thisMod
m = mkModule (moduleUnit thisMod) expMod -- Identity module!
-- Note [1]:
------------
......
......@@ -14,10 +14,9 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
import Haddock.Types ( MDoc )
import GHC ( Name )
import GHC.Unit.Module ( Module, moduleNameString, moduleName, moduleUnit, unitString )
import GHC.Driver.Session ( DynFlags )
import GHC.Unit.State ( lookupUnit, unitPackageIdString )
import GHC ( Name )
import GHC.Unit.Module ( Module, moduleNameString, moduleName, moduleUnit, unitString )
import GHC.Unit.State ( UnitState, lookupUnit, unitPackageIdString )
import qualified Control.Applicative as A
......@@ -25,14 +24,14 @@ import qualified Control.Applicative as A
data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree]
mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree]
mkModuleTree dflags showPkgs mods =
mkModuleTree :: UnitState -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree]
mkModuleTree state showPkgs mods =
foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ]
where
modPkg mod_ | showPkgs = Just (unitString (moduleUnit mod_))
| otherwise = Nothing
modSrcPkg mod_ | showPkgs = fmap unitPackageIdString
(lookupUnit dflags (moduleUnit mod_))
(lookupUnit state (moduleUnit mod_))
| otherwise = Nothing
fn (m,mod_,pkg,srcPkg,short) = addToTrees mod_ m pkg srcPkg short
......
......@@ -45,7 +45,7 @@ import Data.Version
import Control.Applicative
import Distribution.Verbosity
import GHC.Data.FastString
import GHC ( DynFlags, Module, moduleUnit )
import GHC ( DynFlags, Module, moduleUnit, unitState )
import Haddock.Types
import Haddock.Utils
import GHC.Unit.State
......@@ -382,4 +382,4 @@ modulePackageInfo dflags flags (Just modu) =
, optPackageVersion flags <|> fmap unitPackageVersion pkgDb
)
where
pkgDb = lookupUnit dflags (moduleUnit modu)
pkgDb = lookupUnit (unitState dflags) (moduleUnit modu)