+  (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscUIC hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env)

+          (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic old_unit_env) (ue_eud old_unit_env) home_units

+              , ue_uic      = ue_uic old_unit_env

+            , ue_uic      = ue_uic unit_env0

+      (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic unit_env) (ue_eud unit_env) home_units

+    (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_uic old_unit_env) eud (hsc_all_home_unit_ids hsc_env)

+          , ue_uic = ue_uic old_unit_env

+   , hscUIC

+import GHC.Unit.External.Index

+hscUnitIndex hsc_env = ueUI (hsc_unit_env hsc_env)

+hscUIC :: HscEnv -> UnitIndexCache

+hscUIC hsc_env = ue_uic (hsc_unit_env hsc_env)

+    (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) (hscEUDC hsc_env) home_units

+    , ueEUD

+    , ueUI

+import GHC.Unit.External.Index

+        -- ^ Global cache of already read package databases

+

+    , ue_uic :: {-# UNPACK #-} !UnitIndexCache

+        -- ^ Index of already processed 'UnitInfo's.

+        -- Shares state over all 'UnitState' in the 'HomeUnitGraph'.

+ueEUD :: UnitEnv -> IO (ExternalUnitDatabases UnitId)

+ueEUD = readExternalUnitDatabases . ue_eud

+

+ueUI :: UnitEnv -> IO UnitIndex

+ueUI = readUnitIndex . ue_uic

+

+

+  uic <- initUnitIndexCache

+    , ue_uic      = uic

+  -- * Mutable cache for 'ExternalUnitDatabases'

+  -- * 'ExternalUnitDatabases'

+  -- * 'UnitDatabase'

+  mergeDatabases,

+  UnitPrecedenceMap,

+  sortByPreference,

+  compareByPreference,

+  -- * Reading packages from disk.

+  UnitDbConfig(..),

+  readOrGetUnitDatabase,

+  readUnitDatabases,

+  readUnitDatabase,

+  getUnitDbRefs,

+  resolveUnitDatabase,

+import GHC.Data.Maybe

+import GHC.Data.OsPath (OsPath)

+import GHC.Data.OsPath qualified as OsPath

+import GHC.Data.ShortText qualified as ST

+import GHC.Driver.DynFlags

+import GHC.Platform.ArchOS

+import GHC.Types.Unique.Map

+import GHC.Unit.Database

+import GHC.Unit.Types

+import GHC.Utils.Error

+import GHC.Utils.Exception

+import GHC.Utils.Logger

+import GHC.Utils.Misc

+import GHC.Utils.Outputable as Outputable

+import GHC.Utils.Panic

+import Control.Monad

+import Data.Char

+import Data.IORef

+import Data.List (sortBy)

+import Data.Map.Strict (Map)

+import Data.Ord

+import Data.Set (Set)

+import Data.Set qualified as Set

+import System.Directory

+import System.Environment (getEnv)

+import System.FilePath as FilePath

+

+-- ----------------------------------------------------------------------------

+--

+-- Merging databases

+--

+

+-- | For each unit, a mapping from uid -> i indicates that this

+-- unit was brought into GHC by the ith @-package-db@ flag on

+-- the command line.  We use this mapping to make sure we prefer

+-- units that were defined later on the command line, if there

+-- is an ambiguity.

+type UnitPrecedenceMap = UniqMap UnitId Int

+

+-- | Given a list of databases, merge them together, where

+-- units with the same unit id in later databases override

+-- earlier ones.  This does NOT check if the resulting database

+-- makes sense (that's done by 'validateDatabase').

+mergeDatabases :: Logger -> [UnitDatabase UnitId]

+               -> IO (UnitInfoMap, UnitPrecedenceMap)

+mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..]

+  where

+    merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do

+      debugTraceMsg logger 2 $

+          text "loading package database" <+> ppr db_path

+      when (logVerbAtLeast logger 2) $

+        forM_ (Set.toList override_set) $ \pkg ->

+            debugTraceMsg logger 2 $

+                text "package" <+> ppr pkg <+>

+                text "overrides a previously defined package"

+      return (pkg_map', prec_map')

+     where

+      db_map = mk_pkg_map db

+      mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p))

+

+      -- The set of UnitIds which appear in both db and pkgs.  These are the

+      -- ones that get overridden.  Compute this just to give some

+      -- helpful debug messages at -v2

+      override_set :: Set UnitId

+      override_set = Set.intersection (nonDetUniqMapToKeySet db_map)

+                                      (nonDetUniqMapToKeySet pkg_map)

+

+      -- Now merge the sets together (NB: in case of duplicate,

+      -- first argument preferred)

+      pkg_map' :: UnitInfoMap

+      pkg_map' = pkg_map `plusUniqMap` db_map

+

+      prec_map' :: UnitPrecedenceMap

+      prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map)

+

+-- | This sorts a list of packages, putting "preferred" packages first.

+-- See 'compareByPreference' for the semantics of "preference".

+sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]

+sortByPreference prec_map = sortBy (flip (compareByPreference prec_map))

+

+-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking

+-- which should be "active".  Here is the order of preference:

+--

+--      1. First, prefer the latest version

+--      2. If the versions are the same, prefer the package that

+--      came in the latest package database.

+--

+-- Pursuant to #12518, we could change this policy to, for example, remove

+-- the version preference, meaning that we would always prefer the units

+-- in later unit database.

+compareByPreference

+    :: UnitPrecedenceMap

+    -> UnitInfo

+    -> UnitInfo

+    -> Ordering

+compareByPreference prec_map pkg pkg'

+  = case comparing unitPackageVersion pkg pkg' of

+        GT -> GT

+        EQ | Just prec  <- lookupUniqMap prec_map (unitId pkg)

+           , Just prec' <- lookupUniqMap prec_map (unitId pkg')

+           -- Prefer the unit from the later DB flag (i.e., higher

+           -- precedence)

+           -> compare prec prec'

+           | otherwise

+           -> EQ

+        LT -> LT

+

+-- -----------------------------------------------------------------------------

+-- Reading the unit database(s)

+

+data UnitDbConfig = UnitDbConfig

+  { unitDbConfigFlagsDB :: [PackageDBFlag]

+  , unitDbConfigProgramName :: String

+  , unitDbConfigDBName :: FilePath

+  , unitDbConfigPlatformArchOS :: ArchOS

+  , unitDbConfigGlobalDB :: FilePath

+  , unitDbConfigGHCDir :: FilePath

+  }

+

+readUnitDatabases :: Logger -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> IO [UnitDatabase UnitId]

+readUnitDatabases logger db_cache cfg = do

+  conf_refs <- getUnitDbRefs cfg

+  confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs

+  mapM (readOrGetUnitDatabase logger db_cache cfg) confs

+

+

+getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef]

+getUnitDbRefs cfg = do

+  let system_conf_refs = [UserPkgDb, GlobalPkgDb]

+

+  e_pkg_path <- tryIO (getEnv $ map toUpper (unitDbConfigProgramName cfg) ++ "_PACKAGE_PATH")

+  let base_conf_refs = case e_pkg_path of

+        Left _ -> system_conf_refs

+        Right path

+         | Just (xs, x) <- snocView path, isSearchPathSeparator x

+         -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs

+         | otherwise

+         -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path))

+

+  -- Apply the package DB-related flags from the command line to get the

+  -- final list of package DBs.

+  --

+  -- Notes on ordering:

+  --  * The list of flags is reversed (later ones first)

+  --  * We work with the package DB list in "left shadows right" order

+  --  * and finally reverse it at the end, to get "right shadows left"

+  --

+  return $ reverse (foldr doFlag base_conf_refs (unitDbConfigFlagsDB cfg))

+ where

+  doFlag (PackageDB p) dbs = p : dbs

+  doFlag NoUserPackageDB dbs = filter isNotUser dbs

+  doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs

+  doFlag ClearPackageDBs _ = []

+

+  isNotUser UserPkgDb = False

+  isNotUser _ = True

+

+  isNotGlobal GlobalPkgDb = False

+  isNotGlobal _ = True

+

+-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing'

+-- when the user database filepath is expected but the latter doesn't exist.

+--

+-- NB: This logic is reimplemented in Cabal, so if you change it,

+-- make sure you update Cabal. (Or, better yet, dump it in the

+-- compiler info so Cabal can use the info.)

+resolveUnitDatabase :: UnitDbConfig -> PkgDbRef -> IO (Maybe OsPath)

+resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitDbConfigGlobalDB cfg

+resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do

+  dir <- versionedAppDir (unitDbConfigProgramName cfg) (unitDbConfigPlatformArchOS cfg)

+  let pkgconf = dir </> unitDbConfigDBName cfg

+  exist <- tryMaybeT $ doesDirectoryExist pkgconf

+  if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero

+resolveUnitDatabase _ (PkgDbPath name) = return $ Just name

+

+-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location.

+readOrGetUnitDatabase :: Logger -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)

+readOrGetUnitDatabase logger db_cache cfg conf_file =

+  readExternalUnitDatabase db_cache conf_file >>= \ case

+    Nothing -> do

+      new_db <- readUnitDatabase logger cfg conf_file

+      cacheExternalUnitDatabase db_cache new_db

+      pure new_db

+    Just db ->

+      pure db

+

+-- | Read the 'UnitDatabase' at the given location.

+readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)

+readUnitDatabase logger cfg conf_file = do

+  isdir <- OsPath.doesDirectoryExist conf_file

+

+  proto_pkg_configs <-

+    if isdir

+       then readDirStyleUnitInfo conf_file

+       else do

+            isfile <- OsPath.doesFileExist conf_file

+            if isfile

+               then do

+                 mpkgs <- tryReadOldFileStyleUnitInfo

+                 case mpkgs of

+                   Just pkgs -> return pkgs

+                   Nothing   -> throwGhcExceptionIO $ InstallationError $

+                      "ghc no longer supports single-file style package " ++

+                      "databases (" ++ show conf_file ++

+                      ") use 'ghc-pkg init' to create the database with " ++

+                      "the correct format."

+               else throwGhcExceptionIO $ InstallationError $

+                      "can't find a package database at " ++ show conf_file

+

+  let

+      -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot

+      conf_file' = OsPath.dropTrailingPathSeparator conf_file

+      top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg)

+      pkgroot = OsPath.takeDirectory conf_file'

+      pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)

+                         proto_pkg_configs

+  --

+  pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1

+  return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2

+  where

+    readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]

+    readDirStyleUnitInfo conf_dir = do

+      let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache")

+      cache_exists <- OsPath.doesFileExist filename

+      if cache_exists

+        then do

+          debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename

+          readPackageDbForGhc filename

+        else do

+          -- If there is no package.cache file, we check if the database is not

+          -- empty by inspecting if the directory contains any .conf file. If it

+          -- does, something is wrong and we fail. Otherwise we assume that the

+          -- database is empty.

+          debugTraceMsg logger 2 $ text "There is no package.cache in"

+                      <+> ppr conf_dir

+                       <> text ", checking if the database is empty"

+          db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf"))

+                   <$> OsPath.getDirectoryContents conf_dir

+          if db_empty

+            then do

+              debugTraceMsg logger 3 $ text "There are no .conf files in"

+                          <+> ppr conf_dir <> text ", treating"

+                          <+> text "package database as empty"

+              return []

+            else

+              throwGhcExceptionIO $ InstallationError $

+                "there is no package.cache in " ++ show conf_dir ++

+                " even though package database is not empty"

+

+

+    -- Single-file style package dbs have been deprecated for some time, but

+    -- it turns out that Cabal was using them in one place. So this is a

+    -- workaround to allow older Cabal versions to use this newer ghc.

+    -- We check if the file db contains just "[]" and if so, we look for a new

+    -- dir-style db in conf_file.d/, ie in a dir next to the given file.

+    -- We cannot just replace the file with a new dir style since Cabal still

+    -- assumes it's a file and tries to overwrite with 'writeFile'.

+    -- ghc-pkg also cooperates with this workaround.

+    tryReadOldFileStyleUnitInfo = do

+      content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return ""

+      if take 2 content == "[]"

+        then do

+          let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d"

+          direxists <- OsPath.doesDirectoryExist conf_dir

+          if direxists

+             then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir)

+                     liftM Just (readDirStyleUnitInfo conf_dir)

+             else return (Just []) -- ghc-pkg will create it when it's updated

+        else return Nothing

+

+mungeUnitInfo :: OsPath -> OsPath

+                   -> UnitInfo -> UnitInfo

+mungeUnitInfo top_dir pkgroot =

+    mungeBytecodeLibFields

+  . mungeLibDirFields

+  . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot))

+

+mungeLibDirFields :: UnitInfo -> UnitInfo

+mungeLibDirFields pkg =

+    pkg {

+      unitLibraryDynDirs = case unitLibraryDynDirs pkg of

+         [] -> unitLibraryDirs pkg

+         ds -> ds

+      , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of

+         [] -> unitLibraryDirs pkg

+         ds -> ds

+    }

+

+-- | Default to using library-dirs if bytecode library dirs is not explicitly set.

+mungeBytecodeLibFields :: UnitInfo -> UnitInfo

+mungeBytecodeLibFields pkg =

+    pkg {

+      unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of

+         [] -> unitLibraryDirs pkg

+         ds -> ds

+    }

+module GHC.Unit.External.Index (

+  -- * The 'UnitIndexCache'.

+  -- A mutable wrapper around 'UnitIndex'

+  UnitIndexCache(..),

+  initUnitIndexCache,

+  readUnitIndex,

+  modifyUnitIndexCache,

+  clearUnitIndexCache,

+  -- * 'UnitIndex'

+  UnitIndex,

+  emptyUnitIndex,

+  wiringMap,

+  unwiringMap,

+  globalUnits,

+  setWireMap,

+  wireMapExists,

+  addUnitInfoMap,

+  -- * 'GlobalUnitInfoMap'

+  GlobalUnitInfoMap,

+  lookupGlobalUnitInfoMap,

+  emptyGlobalUnitInfoMap,

+  mkGlobalUnitInfoMap,

+  -- * 'GlobalUnitKey'

+  GlobalUnitKey,

+  UnitAbiHash,

+  mkGlobalUnitKey,

+  globalUnitKeyFromUnitInfo,

+  -- * Wired-in units

+  unwireUnit,

+  updateWiredInUnits,

+  updateWiredInUnitsInUnitInfo,

+  updateWiredInUnitIdInModule,

+) where

+

+import GHC.Prelude

+

+import GHC.Data.ShortText qualified as ST

+import GHC.Types.Unique.Map

+import GHC.Unit.Database

+import GHC.Unit.External.Wired

+import GHC.Unit.Info

+import GHC.Unit.Types

+

+import Data.IORef (IORef)

+import Data.IORef qualified as IORef

+import Data.Map.Strict (Map)

+import Data.Map.Strict qualified as Map

+

+-- ----------------------------------------------------------------------------

+-- UnitIndex

+-- ----------------------------------------------------------------------------

+

+newtype UnitIndexCache = UnitIndexCache

+  { uic_index :: IORef UnitIndex

+  }

+

+initUnitIndexCache :: IO UnitIndexCache

+initUnitIndexCache =

+  UnitIndexCache <$> IORef.newIORef emptyUnitIndex

+

+readUnitIndex :: UnitIndexCache -> IO UnitIndex

+readUnitIndex eudc =

+  IORef.readIORef (uic_index eudc)

+

+modifyUnitIndexCache :: UnitIndexCache -> (UnitIndex -> UnitIndex) -> IO ()

+modifyUnitIndexCache eudc f =

+  IORef.modifyIORef' (uic_index eudc) f

+

+clearUnitIndexCache :: UnitIndexCache -> IO ()

+clearUnitIndexCache eudc =

+  modifyUnitIndexCache eudc (const emptyUnitIndex)

+

+data UnitIndex = UnitIndex

+  { ui_wireMap :: !WireMap

+    -- ^ A mapping from database unit keys to wired in unit ids.

+  , ui_unwireMap :: !UnwireMap

+    -- ^ A mapping from wired in unit ids to unit keys from the database.

+  , ui_unitInfoMap :: !GlobalUnitInfoMap

+    -- ^ TODO @fendor: document

+  }

+

+wiringMap :: UnitIndex -> WireMap

+wiringMap = ui_wireMap

+

+unwiringMap :: UnitIndex -> UnwireMap

+unwiringMap = ui_unwireMap

+

+globalUnits :: UnitIndex -> GlobalUnitInfoMap

+globalUnits = ui_unitInfoMap

+

+emptyUnitIndex :: UnitIndex

+emptyUnitIndex = UnitIndex

+  { ui_wireMap = emptyWireMap

+  , ui_unwireMap = emptyUnwireMap

+  , ui_unitInfoMap = emptyGlobalUnitInfoMap

+  }

+

+setWireMap :: WireMap -> UnitIndex -> UnitIndex

+setWireMap wired_map unit_index =

+  unit_index

+    { ui_wireMap = wired_map

+    , ui_unwireMap = unwiringMapFromWireMap wired_map

+    }

+

+wireMapExists :: UnitIndex -> Bool

+wireMapExists unit_index =

+  not $ isWireMapEmpty (ui_wireMap unit_index)

+

+addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex

+addUnitInfoMap unit_info_map unit_index =

+  unit_index

+    { ui_unitInfoMap =

+        -- Order should not matter, either it is exactly the same 'UnitInfo',

+        -- or a new one.

+        GlobalUnitInfoMap $ plusUniqMap_C Map.union newEntriesMap oldMap

+    }

+  where

+    GlobalUnitInfoMap newEntriesMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map

+    GlobalUnitInfoMap oldMap = ui_unitInfoMap unit_index

+

+-- ----------------------------------------------------------------------------

+-- GlobalUnitInfoMap

+-- ----------------------------------------------------------------------------

+

+type UnitAbiHash = ST.ShortText

+

+-- | A

+newtype GlobalUnitInfoMap = GlobalUnitInfoMap (UniqMap UnitId (Map UnitAbiHash UnitInfo))

+

+lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo

+lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) (GlobalUnitInfoMap globalMap) =

+  case lookupUniqMap globalMap uid of

+    Nothing -> Nothing

+    Just sameUnitId -> Map.lookup abiHash sameUnitId

+

+mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap

+mkGlobalUnitInfoMap unitInfos =

+  GlobalUnitInfoMap $ listToUniqMap_C Map.union (map mkEntry unitInfos)

+ where

+  mkEntry (uid, v) = (uid, Map.singleton (unitAbiHash v) v)

+

+emptyGlobalUnitInfoMap :: GlobalUnitInfoMap

+emptyGlobalUnitInfoMap = GlobalUnitInfoMap emptyUniqMap

+

+-- ----------------------------------------------------------------------------

+-- GlobalUnitKey

+-- ----------------------------------------------------------------------------

+

+-- | A 'GlobalUnitKey' is a key that can globally identify a 'UnitInfo', not just

+-- in the 'UnitInfoMap'.

+data GlobalUnitKey =

+  GlobalUnitKey

+    !UnitId -- ^ Unit Id of the 'UnitInfo'

+    !UnitAbiHash -- ^ ABI hash of the 'UnitInfo'

+

+globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey

+globalUnitKeyFromUnitInfo ui = mkGlobalUnitKey (unitId ui) (unitAbiHash ui)

+

+mkGlobalUnitKey :: UnitId -> UnitAbiHash -> GlobalUnitKey

+mkGlobalUnitKey = GlobalUnitKey

+

+-- -----------------------------------------------------------------------------

+-- Wired-in units

+--

+-- See Note [Wired-in units] in GHC.Unit.Types

+

+-- | Given a wired-in 'Unit', "unwire" it into the 'Unit'

+-- that it was recorded as in the package database.

+unwireUnit :: UnitIndex -> Unit -> Unit

+unwireUnit state uid@(RealUnit (Definite def_uid)) =

+    maybe uid (RealUnit . Definite) (lookupUnwireMap def_uid (unwiringMap state))

+unwireUnit _ uid = uid

+

+updateWiredInUnits :: WireMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo]

+updateWiredInUnits wiredInMap knownInfos pkgs =

+  map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs

+

+updateWiredInUnitsInUnitInfo :: WireMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo

+updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg =

+  let

+    upd_wired_in_pkg wiredInUnitId pkg =

+      pkg { unitId         = wiredInUnitId

+          , unitInstanceOf = wiredInUnitId

+              -- every non instantiated unit is an instance of

+              -- itself (required by Backpack...)

+              --

+              -- See Note [About units] in GHC.Unit

+          }

+

+    upd_deps pkg = pkg {

+          unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg),

+          unitExposedModules

+            = map (\(k,v) -> (k, fmap (updateWiredInUnitIdInModule wiredInMap) v))

+                  (unitExposedModules pkg)

+        }

+  in

+    case lookupWireMap (unitId pkg) wiredInMap of

+      Just wiredIn ->

+        case lookupGlobalUnitInfoMap (mkGlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of

+          Just ui ->

+            Right ui

+          Nothing ->

+            let

+              updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg

+            in

+              Left $ seqUnitInfo updated_pkg updated_pkg

+      Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of

+        Just ui ->

+          Right ui

+        Nothing ->

+          let

+            updated_pkg = upd_deps pkg

+          in

+            Left $ seqUnitInfo updated_pkg updated_pkg

+

+-- Helper functions for rewiring Module and Unit.  These

+-- rewrite Units of modules in wired-in packages to the form known to the

+-- compiler, as described in Note [Wired-in units] in GHC.Unit.Types.

+--

+-- For instance, base-4.9.0.0 will be rewritten to just base, to match

+-- what appears in GHC.Builtin.Names.

+

+updateWiredInUnitIdInModule :: WireMap -> Module -> Module

+updateWiredInUnitIdInModule wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m

+

+upd_wired_in_uid :: WireMap -> Unit -> Unit

+upd_wired_in_uid wiredInMap u = case u of

+   HoleUnit -> HoleUnit

+   RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid))

+   VirtUnit indef_uid ->

+      VirtUnit $ mkInstantiatedUnit

+        (instUnitInstanceOf indef_uid)

+        (map (\(x,y) -> (x,updateWiredInUnitIdInModule wiredInMap y)) (instUnitInsts indef_uid))

+

+upd_wired_in :: WireMap -> UnitId -> UnitId

+upd_wired_in wiredInMap key

+    | Just key' <- lookupWireMap key wiredInMap = key'

+    | otherwise = key

+module GHC.Unit.External.ModuleOrigin (

+  ModuleOrigin(..),

+  fromExposedModules,

+  fromReexportedModules,

+  fromFlag,

+  originVisible,

+  originEmpty,

+) where

+

+import GHC.Prelude

+import GHC.Unit.External.Validate

+import GHC.Unit.Info

+import GHC.Utils.Outputable

+import GHC.Utils.Panic

+import qualified Data.Semigroup as Semigroup

+

+-- | Given a module name, there may be multiple ways it came into scope,

+-- possibly simultaneously.  This data type tracks all the possible ways

+-- it could have come into scope.  Warning: don't use the record functions,

+-- they're partial!

+data ModuleOrigin =

+    -- | Module is hidden, and thus never will be available for import.

+    -- (But maybe the user didn't realize), so we'll still keep track

+    -- of these modules.)

+    ModHidden

+

+    -- | Module is unavailable because the unit is unusable.

+  | ModUnusable !UnusableUnit

+

+    -- | Module is public, and could have come from some places.

+  | ModOrigin {

+        -- | @Just False@ means that this module is in

+        -- someone's @exported-modules@ list, but that package is hidden;

+        -- @Just True@ means that it is available; @Nothing@ means neither

+        -- applies.

+        fromOrigUnit :: Maybe Bool

+        -- | Is the module available from a reexport of an exposed package?

+        -- There could be multiple.

+      , fromExposedReexport :: [UnitInfo]

+        -- | Is the module available from a reexport of a hidden package?

+      , fromHiddenReexport :: [UnitInfo]

+        -- | Did the module export come from a package flag? (ToDo: track

+        -- more information.

+      , fromPackageFlag :: Bool

+      }

+

+instance Outputable ModuleOrigin where

+    ppr ModHidden = text "hidden module"

+    ppr (ModUnusable _) = text "unusable module"

+    ppr (ModOrigin e res rhs f) = sep (punctuate comma (

+        (case e of

+            Nothing -> []

+            Just False -> [text "hidden package"]

+            Just True -> [text "exposed package"]) ++

+        (if null res

+            then []

+            else [text "reexport by" <+>

+                    sep (map (ppr . mkUnit) res)]) ++