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

Unit fields moved from DynFlags to HscEnv

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)