Merge pull request #1202 from hsyl20/wip/hsyl20/unitid-ii

Fix after unit refactoring

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)