From 760cd58cfafe1ff25fcceed88ad2c824f10f6d6b Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Thu, 7 May 2020 21:28:39 +0200 Subject: Fix after unit refactoring --- haddock-api/src/Haddock.hs | 7 ++++--- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml.hs | 15 +++++++------- haddock-api/src/Haddock/Interface.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 23 +++++++++++----------- haddock-api/src/Haddock/ModuleTree.hs | 13 ++++++------ haddock-api/src/Haddock/Options.hs | 4 ++-- 7 files changed, 33 insertions(+), 33 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 8ef8f5ca..63ceeb16 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -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 diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 41591c6e..19c72335 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -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 diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index cfbaffc6..24b565fc 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -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] diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index b35b54e0..255cbdbc 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -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 diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 786779c6..5e09fec6 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -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]: ------------ diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index 688e3e71..d0a39322 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -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 diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 011a361d..5c9bf448 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -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) -- cgit v1.2.3