Merge pull request #1258 from hsyl20/wip/hsyl20/hscenv/unitstate

Unit fields moved from DynFlags to HscEnv

4 files changed, 24 insertions, 20 deletions

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)