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

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

+              , ue_unit_index      = ue_unit_index old_unit_env

+            , ue_unit_index      = ue_unit_index unit_env0

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

+    env <- getSession

+    unitIndex <- liftIO $ hscUnitIndex env

+          hscUpdateFlags (\dflags -> mk_temp_dflags unitIndex (hsc_units hsc_env) dflags) hsc_env

+        mk_temp_dflags unit_index unit_state dflags = dflags

+              let uid = unwireUnit unit_index

+        unit_index <- liftIO $ hscUnitIndex hsc_env

+                        _ -> map (toUnitId . unwireUnit unit_index)

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

+          , ue_unit_index = ue_unit_index old_unit_env

+   , hscUnitIndex

+   , hsc_unit_index

+hscUnitIndex :: HscEnv -> IO UnitIndex

+hscUnitIndex hsc_env = readIORef $ ue_unit_index (hsc_unit_env hsc_env)

+

+hsc_unit_index :: HscEnv -> IORef UnitIndex

+hsc_unit_index hsc_env = ue_unit_index (hsc_unit_env hsc_env)

+

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

+-- These are sometimes also referred to as \"keys\" in comments in GHC.

+import Data.IORef

+    , ue_unit_index :: {-# UNPACK #-} !(IORef UnitIndex)

+        -- TODO: @fendor Docs

+  unit_index <- newIORef (initUnitIndex)

+    , ue_unit_index      = unit_index

+  -- *

+  mergeDatabases,

+  validateDatabase,

+  UnitPrecedenceMap,

+  sortByPreference,

+  compareByPreference,

+  -- *

+  UnitDbConfig(..),

+  readOrGetUnitDatabase,

+  readUnitDatabases,

+  readUnitDatabase,

+  getUnitDbRefs,

+  resolveUnitDatabase,

+  -- *

+  matchingStr,

+  matchingId,

+  matching,

+import GHC.Driver.DynFlags

+import Control.Monad

+import Data.Char

+import Data.Graph (SCC (..), stronglyConnComp)

+import Data.IORef

+import Data.List (partition, sortBy)

+import Data.Map.Strict (Map)

+import Data.Ord

+import Data.Set (Set)

+import Data.Set qualified as Set

+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.Platform.ArchOS

+import GHC.Types.Unique.Map

+import GHC.Unit.Database

+import GHC.Unit.External.Validate

+import GHC.Unit.Info

+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 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)

+

+-- | Validates a database, removing unusable units from it

+-- (this includes removing units that the user has explicitly

+-- ignored.)  Our general strategy:

+--

+-- 1. Remove all broken units (dangling dependencies)

+-- 2. Remove all units that are cyclic

+-- 3. Apply ignore flags

+-- 4. Remove all units which have deps with mismatching ABIs

+--

+validateDatabase :: [IgnorePackageFlag] -> UnitInfoMap

+                 -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo])

+validateDatabase flagsIgnored pkg_map1 =

+    (pkg_map5, unusable, sccs)

+  where

+    ignore_flags = reverse flagsIgnored -- (unitConfigFlagsIgnored cfg)

+

+    -- Compute the reverse dependency index

+    index = reverseDeps pkg_map1

+

+    -- Helper function

+    mk_unusable mk_err dep_matcher m uids =

+      listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg)))

+                    | pkg <- uids

+                    ]

+

+    -- Find broken units

+    directly_broken = filter (not . null . depsNotAvailable pkg_map1)

+                             (nonDetEltsUniqMap pkg_map1)

+    (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1

+    unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken

+

+    -- Find recursive units

+    sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg)

+                            | pkg <- nonDetEltsUniqMap pkg_map2 ]

+    getCyclicSCC (CyclicSCC vs) = map unitId vs

+    getCyclicSCC (AcyclicSCC _) = []

+    (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2

+    unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic

+

+    -- Apply ignore flags

+    directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3)

+    (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3

+    unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored

+

+    -- Knock out units whose dependencies don't agree with ABI

+    -- (i.e., got invalidated due to shadowing)

+    directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4)

+                               (nonDetEltsUniqMap pkg_map4)

+    (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4

+    unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed

+

+    -- combine all unusables. The order is important for shadowing.

+    -- plusUniqMapList folds using plusUFM which is right biased (opposite of

+    -- Data.Map.union) so the head of the list should be the least preferred

+    unusable = plusUniqMapList [ unusable_shadowed

+                               , unusable_cyclic

+                               , unusable_broken

+                               , unusable_ignored

+                               , directly_ignored

+                               ]

+

+

+-- | 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

+  , unitDbConfigDBCache :: ExternalUnitDatabaseCache UnitId

+  }

+

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

+readUnitDatabases logger cfg = do

+  conf_refs <- getUnitDbRefs cfg

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

+  mapM (readOrGetUnitDatabase logger 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 -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)

+readOrGetUnitDatabase logger cfg conf_file =

+  readExternalUnitDatabase (unitDbConfigDBCache cfg) conf_file >>= \ case

+    Nothing -> do

+      new_db <- readUnitDatabase logger cfg conf_file

+      cacheExternalUnitDatabase (unitDbConfigDBCache cfg) 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

+    }

+

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

+--

+-- Utilities on the database

+--

+

+-- | A reverse dependency index, mapping an 'UnitId' to

+-- the 'UnitId's which have a dependency on it.

+type RevIndex = UniqMap UnitId [UnitId]

+

+-- | Compute the reverse dependency index of a unit database.

+reverseDeps :: UnitInfoMap -> RevIndex

+reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db

+  where

+    go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex

+    go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg)

+    go' from r to = addToUniqMap_C (++) r to [from]

+

+-- | Given a list of 'UnitId's to remove, a database,

+-- and a reverse dependency index (as computed by 'reverseDeps'),

+-- remove those units, plus any units which depend on them.

+-- Returns the pruned database, as well as a list of 'UnitInfo's

+-- that was removed.

+removeUnits :: [UnitId] -> RevIndex

+               -> UnitInfoMap

+               -> (UnitInfoMap, [UnitInfo])

+removeUnits uids index m = go uids (m,[])

+  where

+    go [] (m,pkgs) = (m,pkgs)

+    go (uid:uids) (m,pkgs)

+        | Just pkg <- lookupUniqMap m uid

+        = case lookupUniqMap index uid of

+            Nothing    -> go uids (delFromUniqMap m uid, pkg:pkgs)

+            Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs)

+        | otherwise

+        = go uids (m,pkgs)

+

+-- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends'

+-- which correspond to units that do not exist in the index.

+depsNotAvailable :: UnitInfoMap

+                 -> UnitInfo

+                 -> [UnitId]

+depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg)

+

+-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in

+-- 'unitAbiDepends' which correspond to units that do not exist, OR have

+-- mismatching ABIs.

+depsAbiMismatch :: UnitInfoMap

+                -> UnitInfo

+                -> [UnitId]

+depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg

+  where

+    abiMatch (dep_uid, abi)

+        | Just dep_pkg <- lookupUniqMap pkg_map dep_uid

+        = unitAbiHash dep_pkg == abi

+        | otherwise

+        = False

+

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

+-- Ignore units

+

+ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits

+ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags)

+  where

+  doit (IgnorePackage str) =

+     case partition (matchingStr str) pkgs of

+         (ps, _) -> [ (unitId p, (p, IgnoredWithFlag))

+                    | p <- ps ]

+        -- missing unit is not an error for -ignore-package,

+        -- because a common usage is to -ignore-package P as

+        -- a preventative measure just in case P exists.

+

+-- A package named on the command line can either include the

+-- version, or just the name if it is unambiguous.

+matchingStr :: String -> UnitInfo -> Bool

+matchingStr str p

+        =  str == unitPackageIdString p

+        || str == unitPackageNameString p

+

+matchingId :: UnitId -> UnitInfo -> Bool

+matchingId uid p = uid == unitId p

+

+matching :: PackageArg -> UnitInfo -> Bool

+matching (PackageArg str) = matchingStr str

+matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid

+matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case

+module GHC.Unit.External.Index (

+  -- *

+  UnitIndex,

+  initUnitIndex,

+  wiringMap,

+  unwiringMap,

+  globalUnits,

+  setWireMap,

+  isWireMapEmpty,

+  addUnitInfoMap,

+

+  -- *

+  GlobalUnitInfoMap,

+  lookupGlobalUnitInfoMap,

+  mkGlobalUnitKey,

+

+  -- *

+  GlobalUnitKey,

+  globalUnitKeyFromUnitInfo,

+

+  -- *

+  updateWiredInUnits,

+  updateWiredInUnitsInUnitInfo,

+  upd_wired_in_mod,

+) 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.Map.Strict (Map)

+import Data.Map.Strict qualified as Map

+import GHC.Utils.Misc

+

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

+-- UnitIndex

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

+

+data UnitIndex = UnitIndex

+  { ui_wireMap :: !WiringMap

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

+  , ui_unwireMap :: !UnwiringMap

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

+  , ui_unitInfoMap :: !GlobalUnitInfoMap

+    -- ^ TODO @fendor: document

+  }

+

+wiringMap :: UnitIndex -> UnwiringMap

+wiringMap = ui_unwireMap

+

+unwiringMap :: UnitIndex -> WiringMap

+unwiringMap = ui_wireMap

+

+globalUnits :: UnitIndex -> GlobalUnitInfoMap

+globalUnits = ui_unitInfoMap

+

+initUnitIndex :: UnitIndex

+initUnitIndex = UnitIndex

+  { ui_wireMap = emptyUniqMap

+  , ui_unwireMap = emptyUniqMap

+  , ui_unitInfoMap = emptyUniqMap

+  }

+

+setWireMap :: WiringMap -> UnitIndex -> UnitIndex

+setWireMap wired_map unit_index =

+  unit_index

+    { ui_wireMap = wired_map

+    , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]

+    }

+

+isWireMapEmpty :: UnitIndex -> Bool

+isWireMapEmpty unit_index =

+  isNullUniqMap (ui_wireMap unit_index)

+

+addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex

+addUnitInfoMap unit_info_map unit_index =

+  unit_index

+    { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index)

+    }

+  where

+    globalMap :: GlobalUnitInfoMap

+    globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map

+

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

+-- GlobalUnitInfoMap

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

+

+type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo)

+

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

+lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap =

+  case lookupUniqMap globalMap uid of

+    Nothing -> Nothing

+    Just sameUnitId -> Map.lookup abiHash sameUnitId

+

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

+mkGlobalUnitInfoMap unitInfos =

+  listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos

+

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

+-- GlobalUnitKey

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

+

+data GlobalUnitKey =

+  GlobalUnitKey

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

+    !ST.ShortText

+

+globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey

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

+

+mkGlobalUnitKey :: UnitId -> ST.ShortText -> GlobalUnitKey

+mkGlobalUnitKey = GlobalUnitKey

+

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

+-- Wired-in units

+--

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

+

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