-- | The 'UnitIndex' is a 'UnitEnv' wide data structure that shares
-- external unit information across the 'UnitState' of all home units
-- (e.g., 'HomeUnitEnv') in a particular 'UnitEnv'.
--
-- It caches already read unit databases, all processed 'UnitInfo's and
-- the 'WireMap'.
--
-- This module is meant to be imported as @Index@.
--
-- A short overview of how the different types here related to 'UnitState', 'UnitEnv'
-- and the 'HomeUnitEnv'.
--
-- ┌─────────┐
-- │ UnitEnv │
-- └────┬────┘
--      ├───────────────────────┐
--      │                       │
-- ┌────▼──────┐          ┌─────▼─────┐
-- │HomeUnitEnv│          │ UnitIndex ├────────────────┐
-- └────┬──────┘          └───────────┘                │
--      │                                              │
--      │      Reads cached unit DBs                   │
-- ┌────▼──────┐          ┌─────────────────────┐      │
-- │ UnitState ├──────────>ExternalUnitDatabases◄──────┤
-- └────┬──┬───┘          └─────────────────────┘      │
--      │  └───────────────────────┐                   │
--      │   Writes new UnitInfos   │                   │
--      │   during initialisation  │                   │
-- ┌────▼────────┐        ┌────────v──────────┐        │
-- │ UnitInfoMap │        │ GlobalUnitInfoMap ◄────────┘
-- └────┬────────┘        └────────^──────────┘
--      │                          │
--      └──────────────────────────┘
--          UnitInfoMap references
--          GlobalUnitInfoMap values
--          (All UnitInfos are shared)
--
-- Open arrow @A ───> B@: A uses B.
-- Closed arrow @A ◄─── B@: A is a field of B.
--
-- Also, see Note [Sharing 'UnitInfo's across the 'UnitEnv'] for more technical discussion
-- about sharing 'UnitInfo's.
module GHC.Unit.External.Index (
  -- * The 'UnitIndexCache'.
  -- A mutable wrapper around 'UnitIndex'
  UnitIndexCache(..),
  initUnitIndexCache,
  readUnitIndex,
  modifyUnitIndexCache,
  clearUnitIndexCache,
  cacheExternalUnitDatabase,
  readExternalUnitDatabases,
  readExternalUnitDatabase,
  -- * 'UnitIndex'
  UnitIndex,
  emptyUnitIndex,
  wiringMap,
  unwiringMap,
  globalUnits,
  externalUnitDatabases,
  setWireMap,
  wireMapExists,
  addUnitInfoMap,
  -- * 'GlobalUnitInfoMap'
  GlobalUnitInfoMap,
  lookupGlobalUnitInfoMap,
  emptyGlobalUnitInfoMap,
  mkGlobalUnitInfoMap,
  -- * 'GlobalUnitKey'
  GlobalUnitKey,
  UnitAbiHash,
  mkGlobalUnitKey,
  globalUnitKeyFromUnitInfo,
  -- * Wired-in units
  setupWiredInUnits,
  updateWiredInUnitIndex,
  unwireUnit,
  updateWiredInUnits,
  updateWiredInUnitsInUnitInfo,
  updateWiredInUnitIdInModule,
  -- * Reading external unit databases into the 'UnitIndexCache'
  readOrGetUnitDatabase,
  readUnitDatabases,
) where

import GHC.Prelude

import GHC.Data.OsPath
import GHC.Data.ShortText qualified as ST
import GHC.Types.Unique.Map
import GHC.Unit.Database
import GHC.Unit.External.Database
import GHC.Unit.External.Visibility
import GHC.Unit.External.Wired
import GHC.Unit.Info
import GHC.Unit.Types
import GHC.Utils.Logger

import Control.Monad (liftM)
import Data.Either
import Data.IORef (IORef)
import Data.IORef qualified as IORef
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes)

-- ----------------------------------------------------------------------------
-- UnitIndex
-- ----------------------------------------------------------------------------

-- | Mutable version of 'UnitIndex'.
--
-- The 'UnitIndexCache' ensures that all calls to 'initUnits' will
-- share the 'UnitInfo' if it is possible.
--
-- To share the 'UnitInfo', the 'UnitInfo' needs to be fully-resolved, i.e., its wired-in
-- dependencies and modules need to be replaced with the 'UnitId' of the wired-in unit.
-- Thus, the 'UnitIndexCache' caches both the global 'WireMap' and the 'UnitInfoMap'.
--
-- The 'WireMap' is globally valid, as other parts of the compiler rely on the fact
-- that only one instance of wired-in units is used.
--
-- Memory Invariant: The 'UnitIndexCache' is the root object for retaining fully-resolved
-- 'UnitInfo'. 'UnitState' is expected to reference only 'UnitInfo's from the 'UnitIndexCache'.
-- There is exactly one fully-resolved 'UnitInfo' alive for each external unit per unit database.
--
-- A second instance may or may not be stored in the 'externalUnitDatabases', which represent the
-- in-memory cache of the on-disk unit databases.
newtype UnitIndexCache = UnitIndexCache
  { UnitIndexCache -> IORef UnitIndex
uic_index :: IORef UnitIndex
  }

initUnitIndexCache :: IO UnitIndexCache
initUnitIndexCache :: IO UnitIndexCache
initUnitIndexCache =
  IORef UnitIndex -> UnitIndexCache
IORef UnitIndex -> UnitIndexCache
UnitIndexCache (IORef UnitIndex -> UnitIndexCache)
-> IO (IORef UnitIndex) -> IO UnitIndexCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitIndex -> IO (IORef UnitIndex)
forall a. a -> IO (IORef a)
IORef.newIORef UnitIndex
emptyUnitIndex

readUnitIndex :: UnitIndexCache -> IO UnitIndex
readUnitIndex :: UnitIndexCache -> IO UnitIndex
readUnitIndex UnitIndexCache
uic =
  IORef UnitIndex -> IO UnitIndex
forall a. IORef a -> IO a
IORef.readIORef (UnitIndexCache -> IORef UnitIndex
uic_index UnitIndexCache
uic)

modifyUnitIndexCache :: UnitIndexCache -> (UnitIndex -> UnitIndex) -> IO ()
modifyUnitIndexCache :: UnitIndexCache -> (UnitIndex -> UnitIndex) -> IO ()
modifyUnitIndexCache UnitIndexCache
uic UnitIndex -> UnitIndex
f =
  IORef UnitIndex -> (UnitIndex -> UnitIndex) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef' (UnitIndexCache -> IORef UnitIndex
uic_index UnitIndexCache
uic) UnitIndex -> UnitIndex
f

clearUnitIndexCache :: UnitIndexCache -> IO ()
clearUnitIndexCache :: UnitIndexCache -> IO ()
clearUnitIndexCache UnitIndexCache
uic =
  UnitIndexCache -> (UnitIndex -> UnitIndex) -> IO ()
modifyUnitIndexCache UnitIndexCache
uic (UnitIndex -> UnitIndex -> UnitIndex
forall a b. a -> b -> a
const UnitIndex
emptyUnitIndex)

cacheExternalUnitDatabase :: UnitIndexCache -> UnitDatabase UnitId -> IO ()
cacheExternalUnitDatabase :: UnitIndexCache -> UnitDatabase UnitId -> IO ()
cacheExternalUnitDatabase UnitIndexCache
uic UnitDatabase UnitId
db =
  UnitIndexCache -> (UnitIndex -> UnitIndex) -> IO ()
modifyUnitIndexCache UnitIndexCache
uic
    (\ UnitIndex
ui ->
      UnitIndex
ui
        { ui_externalUnitDatabases = insertExternalUnitDatabases db (ui_externalUnitDatabases ui)
        }
    )

readExternalUnitDatabases :: UnitIndexCache -> IO (ExternalUnitDatabases UnitId)
readExternalUnitDatabases :: UnitIndexCache -> IO (ExternalUnitDatabases UnitId)
readExternalUnitDatabases UnitIndexCache
uic =
  UnitIndex -> ExternalUnitDatabases UnitId
externalUnitDatabases (UnitIndex -> ExternalUnitDatabases UnitId)
-> IO UnitIndex -> IO (ExternalUnitDatabases UnitId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitIndexCache -> IO UnitIndex
readUnitIndex UnitIndexCache
uic

readExternalUnitDatabase :: UnitIndexCache -> OsPath -> IO (Maybe (UnitDatabase UnitId))
readExternalUnitDatabase :: UnitIndexCache -> OsPath -> IO (Maybe (UnitDatabase UnitId))
readExternalUnitDatabase UnitIndexCache
uic OsPath
path = do
  dbs <- UnitIndexCache -> IO (ExternalUnitDatabases UnitId)
readExternalUnitDatabases UnitIndexCache
uic
  pure $ lookupExternalUnitDatabases path dbs

-- | Global index for external units that can be shared across multiple 'HomeUnitEnv's.
--
-- Allows sharing of the 'WireMap' and 'UnitInfo's that are stored in the 'UnitState'
-- of each 'HomeUnitEnv'.
--
-- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for details about memory usage.
data UnitIndex = UnitIndex
  { UnitIndex -> WireMap
ui_wireMap :: !WireMap
    -- ^ A mapping from database unit keys to wired in unit ids.
    --
    -- At the moment, the 'WireMap' is global, there can only be one version of
    -- a wired-in package.
  , UnitIndex -> UnwireMap
ui_unwireMap :: !UnwireMap
    -- ^ A mapping from wired in unit ids to unit keys from the database.
    --
    -- At the moment, the 'UnwireMap' is global, there can only be one version of
    -- a wired-in package.
  , UnitIndex -> GlobalUnitInfoMap
ui_unitInfoMap :: !GlobalUnitInfoMap
    -- ^ A global map for all fully-resolved 'UnitInfo's.
    --
    -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for more details
    -- what we use this for and what a fully-resolved 'UnitInfo' is.
  , UnitIndex -> ExternalUnitDatabases UnitId
ui_externalUnitDatabases :: !(ExternalUnitDatabases UnitId)
    -- ^ Cache the already processed unit databases in-memory.
    --
    -- These 'GenericUnitInfo's have their paths resolved, e.g., no @${pkgroot}@ is
    -- present any more.
  }

-- | Get the 'WireMap'.
--
-- At the moment, the 'WireMap' is global, there can only be one version of
-- a wired-in package.
wiringMap :: UnitIndex -> WireMap
wiringMap :: UnitIndex -> WireMap
wiringMap = UnitIndex -> WireMap
ui_wireMap

-- | Get the 'UnwireMap'.
--
-- At the moment, the 'UnwireMap' is global, there can only be one version of
-- a wired-in package.
unwiringMap :: UnitIndex -> UnwireMap
unwiringMap :: UnitIndex -> UnwireMap
unwiringMap = UnitIndex -> UnwireMap
ui_unwireMap

-- | Access the already processed unit databases.
externalUnitDatabases :: UnitIndex -> ExternalUnitDatabases UnitId
externalUnitDatabases :: UnitIndex -> ExternalUnitDatabases UnitId
externalUnitDatabases = UnitIndex -> ExternalUnitDatabases UnitId
ui_externalUnitDatabases

-- | Access the global map of fully-resolved 'UnitInfo's.
--
-- A 'UnitInfo' is fully-resolved, if its dependencies were updated to reference the
-- wired-in packages (e.g., 'wiringMap') and the wired-in packages are updated.
-- Further, the 'UnitInfo' is based on the 'ExternalUnitDatabases' results, resolving
-- variables such as @${pkgroot}@ in paths.
--
-- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for why this is helpful.
globalUnits :: UnitIndex -> GlobalUnitInfoMap
globalUnits :: UnitIndex -> GlobalUnitInfoMap
globalUnits = UnitIndex -> GlobalUnitInfoMap
ui_unitInfoMap

emptyUnitIndex :: UnitIndex
emptyUnitIndex :: UnitIndex
emptyUnitIndex = UnitIndex
  { ui_wireMap :: WireMap
ui_wireMap = WireMap
emptyWireMap
  , ui_unwireMap :: UnwireMap
ui_unwireMap = UnwireMap
emptyUnwireMap
  , ui_unitInfoMap :: GlobalUnitInfoMap
ui_unitInfoMap = GlobalUnitInfoMap
emptyGlobalUnitInfoMap
  , ui_externalUnitDatabases :: ExternalUnitDatabases UnitId
ui_externalUnitDatabases = ExternalUnitDatabases UnitId
forall unit. ExternalUnitDatabases unit
emptyExternalUnitDatabases
  }

-- | Set the 'WireMap' of 'UnitIndex'.
-- Automatically computes the 'UnwireMap' based on the 'WireMap'.
setWireMap :: WireMap -> UnitIndex -> UnitIndex
setWireMap :: WireMap -> UnitIndex -> UnitIndex
setWireMap WireMap
wired_map UnitIndex
unit_index =
  UnitIndex
unit_index
    { ui_wireMap = wired_map
    , ui_unwireMap = unwiringMapFromWireMap wired_map
    }

-- | Is there already a 'WireMap' in this 'UnitIndex'?
--
wireMapExists :: UnitIndex -> Bool
wireMapExists :: UnitIndex -> Bool
wireMapExists UnitIndex
unit_index =
  Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ WireMap -> Bool
isWireMapEmpty (UnitIndex -> WireMap
ui_wireMap UnitIndex
unit_index)

addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex
addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex
addUnitInfoMap UnitInfoMap
unit_info_map UnitIndex
unit_index =
  UnitIndex
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 UniqMap UnitId (Map UnitAbiHash UnitInfo)
newEntriesMap = [(UnitId, UnitInfo)] -> GlobalUnitInfoMap
mkGlobalUnitInfoMap ([(UnitId, UnitInfo)] -> GlobalUnitInfoMap)
-> [(UnitId, UnitInfo)] -> GlobalUnitInfoMap
forall a b. (a -> b) -> a -> b
$ UnitInfoMap -> [(UnitId, UnitInfo)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UnitInfoMap
unit_info_map
    GlobalUnitInfoMap UniqMap UnitId (Map UnitAbiHash UnitInfo)
oldMap = UnitIndex -> GlobalUnitInfoMap
ui_unitInfoMap UnitIndex
unit_index

-- ----------------------------------------------------------------------------
-- GlobalUnitInfoMap
-- ----------------------------------------------------------------------------

type UnitAbiHash = ST.ShortText

-- | Like a 'UnitInfoMap' but stores all 'UnitInfo's.
--
-- It is keyed by the 'UnitId' and the 'UnitInfo's 'UnitAbiHash'.
-- In modern cabal, there should never be a conflict of 'UnitId's, as cabal
-- hashes the Abi, dependency hashes, source hashes and more.
--
-- However, a user can choose a conflicting 'UnitId', causing a conflict after all.
-- We use the 'UnitAbiHash' for disambiguation. If both 'UnitId' and 'UnitAbiHash' are
-- identical in separate unit databases, we can assume they are the same unit, according
-- to the documentation of GHC.
newtype GlobalUnitInfoMap = GlobalUnitInfoMap (UniqMap UnitId (Map UnitAbiHash UnitInfo))

-- | Lookup the 'UnitInfo' in the 'GlobalUnitInfoMap'.
--
-- This does not check whether the 'GlobalUnitKey' refers to a unit that needs to be resolved
-- in the 'WireMap'.
-- For example, if the 'UnitId' is @ghc-internal-<version>@ (and @ghc-internal@ is a wired-in package),
-- then 'lookupGlobalUnitInfoMap' won't find it, as in the 'GlobalUnitInfoMap', the key is @ghc-internal@.
lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo
lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo
lookupGlobalUnitInfoMap (GlobalUnitKey UnitId
uid UnitAbiHash
abiHash) (GlobalUnitInfoMap UniqMap UnitId (Map UnitAbiHash UnitInfo)
globalMap) =
  case UniqMap UnitId (Map UnitAbiHash UnitInfo)
-> UnitId -> Maybe (Map UnitAbiHash UnitInfo)
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap UnitId (Map UnitAbiHash UnitInfo)
globalMap UnitId
uid of
    Maybe (Map UnitAbiHash UnitInfo)
Nothing -> Maybe UnitInfo
forall a. Maybe a
Nothing
    Just Map UnitAbiHash UnitInfo
sameUnitId -> UnitAbiHash -> Map UnitAbiHash UnitInfo -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitAbiHash
abiHash Map UnitAbiHash UnitInfo
sameUnitId

mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap
mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap
mkGlobalUnitInfoMap [(UnitId, UnitInfo)]
unitInfos =
  UniqMap UnitId (Map UnitAbiHash UnitInfo) -> GlobalUnitInfoMap
UniqMap UnitId (Map UnitAbiHash UnitInfo) -> GlobalUnitInfoMap
GlobalUnitInfoMap (UniqMap UnitId (Map UnitAbiHash UnitInfo) -> GlobalUnitInfoMap)
-> UniqMap UnitId (Map UnitAbiHash UnitInfo) -> GlobalUnitInfoMap
forall a b. (a -> b) -> a -> b
$ (Map UnitAbiHash UnitInfo
 -> Map UnitAbiHash UnitInfo -> Map UnitAbiHash UnitInfo)
-> [(UnitId, Map UnitAbiHash UnitInfo)]
-> UniqMap UnitId (Map UnitAbiHash UnitInfo)
forall k a. Uniquable k => (a -> a -> a) -> [(k, a)] -> UniqMap k a
listToUniqMap_C Map UnitAbiHash UnitInfo
-> Map UnitAbiHash UnitInfo -> Map UnitAbiHash UnitInfo
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (((UnitId, UnitInfo) -> (UnitId, Map UnitAbiHash UnitInfo))
-> [(UnitId, UnitInfo)] -> [(UnitId, Map UnitAbiHash UnitInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, UnitInfo) -> (UnitId, Map UnitAbiHash UnitInfo)
forall {a} {srcpkgid} {srcpkgname} {uid} {modulename} {mod}.
(a, GenericUnitInfo srcpkgid srcpkgname uid modulename mod)
-> (a,
    Map
      UnitAbiHash
      (GenericUnitInfo srcpkgid srcpkgname uid modulename mod))
mkEntry [(UnitId, UnitInfo)]
unitInfos)
 where
  mkEntry :: (a, GenericUnitInfo srcpkgid srcpkgname uid modulename mod)
-> (a,
    Map
      UnitAbiHash
      (GenericUnitInfo srcpkgid srcpkgname uid modulename mod))
mkEntry (a
uid, GenericUnitInfo srcpkgid srcpkgname uid modulename mod
v) = (a
uid, UnitAbiHash
-> GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> Map
     UnitAbiHash
     (GenericUnitInfo srcpkgid srcpkgname uid modulename mod)
forall k a. k -> a -> Map k a
Map.singleton (GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> UnitAbiHash
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> UnitAbiHash
unitAbiHash GenericUnitInfo srcpkgid srcpkgname uid modulename mod
v) GenericUnitInfo srcpkgid srcpkgname uid modulename mod
v)

emptyGlobalUnitInfoMap :: GlobalUnitInfoMap
emptyGlobalUnitInfoMap :: GlobalUnitInfoMap
emptyGlobalUnitInfoMap = UniqMap UnitId (Map UnitAbiHash UnitInfo) -> GlobalUnitInfoMap
GlobalUnitInfoMap UniqMap UnitId (Map UnitAbiHash UnitInfo)
forall k a. UniqMap k a
emptyUniqMap

-- ----------------------------------------------------------------------------
-- GlobalUnitKey
-- ----------------------------------------------------------------------------

-- | A 'GlobalUnitKey' is a key that can globally identify a 'UnitInfo', not just
-- in the 'UnitInfoMap'.
--
-- The 'UnitId' and 'UnitAbiHash' uniquely identify a 'UnitInfo'.
data GlobalUnitKey =
  GlobalUnitKey
    !UnitId -- ^ Unit Id of the 'UnitInfo'
    !UnitAbiHash -- ^ ABI hash of the 'UnitInfo'

globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey
globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey
globalUnitKeyFromUnitInfo UnitInfo
ui = UnitId -> UnitAbiHash -> GlobalUnitKey
mkGlobalUnitKey (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui) (UnitInfo -> UnitAbiHash
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> UnitAbiHash
unitAbiHash UnitInfo
ui)

mkGlobalUnitKey :: UnitId -> UnitAbiHash -> GlobalUnitKey
mkGlobalUnitKey :: UnitId -> UnitAbiHash -> GlobalUnitKey
mkGlobalUnitKey = UnitId -> UnitAbiHash -> GlobalUnitKey
UnitId -> UnitAbiHash -> GlobalUnitKey
GlobalUnitKey

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

-- | Find the wired-in units in the given '[UnitInfo]' if there isn't already
-- one in the 'UnitIndexCache'. If there is, simply return the existing 'WireMap'.
-- Otherwise, update the 'wiringMap' in the 'UnitIndexCache'
setupWiredInUnits :: Logger -> UnitPrecedenceMap -> [UnitInfo] -> VisibilityMap -> UnitIndexCache -> IO WireMap
setupWiredInUnits :: Logger
-> UnitPrecedenceMap
-> [UnitInfo]
-> VisibilityMap
-> UnitIndexCache
-> IO WireMap
setupWiredInUnits Logger
logger UnitPrecedenceMap
prec_map [UnitInfo]
pkgs VisibilityMap
vis_map UnitIndexCache
unit_index = do
  ui <- UnitIndexCache -> IO UnitIndex
readUnitIndex UnitIndexCache
unit_index
  if not $ wireMapExists ui
    then do
      wmap <- findWiredInUnits logger prec_map pkgs vis_map
      modifyUnitIndexCache unit_index (setWireMap wmap)
      pure wmap
    else do
      pure $ ui_wireMap ui

-- | Resolve the wired-in units in the '[UnitInfo]'.
-- If the fully-resolved can be found in 'UnitIndexCache', then we use it.
-- If the resolved 'UnitInfo' is new, we immediately cache it in the 'UnitIndexCache'.
-- We return the fully-resolved 'UnitInfo' list in the same order as provided.
updateWiredInUnitIndex :: WireMap -> [UnitInfo] -> UnitIndexCache -> IO [UnitInfo]
updateWiredInUnitIndex :: WireMap -> [UnitInfo] -> UnitIndexCache -> IO [UnitInfo]
updateWiredInUnitIndex WireMap
wired_map [UnitInfo]
pkgs UnitIndexCache
unit_index = do
  ui <- UnitIndexCache -> IO UnitIndex
readUnitIndex UnitIndexCache
unit_index
  let
    all_pkgs = WireMap
-> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo]
updateWiredInUnits WireMap
wired_map (UnitIndex -> GlobalUnitInfoMap
ui_unitInfoMap UnitIndex
ui) [UnitInfo]
pkgs
    (new_pkgs', _pkgs_set) = partitionEithers all_pkgs
  -- Make sure we force the 'UnitInfo' here.
  -- Otherwise, we will retain a reference to the old 'UnitInfo'
  new_pkgs <- traverse evaluateUnitInfoLists new_pkgs'
  modifyUnitIndexCache unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs)
  pure (map (either id id) all_pkgs)

-- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
-- that it was recorded as in the package database.
unwireUnit :: UnitIndex -> Unit -> Unit
unwireUnit :: UnitIndex -> Unit -> Unit
unwireUnit UnitIndex
state uid :: Unit
uid@(RealUnit (Definite UnitId
def_uid)) =
    Unit -> (UnitId -> Unit) -> Maybe UnitId -> Unit
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Unit
uid (Definite UnitId -> Unit
Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (Definite UnitId -> Unit)
-> (UnitId -> Definite UnitId) -> UnitId -> Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> Definite UnitId
UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite) (UnitId -> UnwireMap -> Maybe UnitId
lookupUnwireMap UnitId
def_uid (UnitIndex -> UnwireMap
unwiringMap UnitIndex
state))
unwireUnit UnitIndex
_ Unit
uid = Unit
uid

updateWiredInUnits :: WireMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo]
updateWiredInUnits :: WireMap
-> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo]
updateWiredInUnits WireMap
wiredInMap GlobalUnitInfoMap
knownInfos [UnitInfo]
pkgs =
  (UnitInfo -> Either UnitInfo UnitInfo)
-> [UnitInfo] -> [Either UnitInfo UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map (WireMap
-> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo
updateWiredInUnitsInUnitInfo WireMap
wiredInMap GlobalUnitInfoMap
knownInfos) [UnitInfo]
pkgs

updateWiredInUnitsInUnitInfo :: WireMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo
updateWiredInUnitsInUnitInfo :: WireMap
-> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo
updateWiredInUnitsInUnitInfo WireMap
wiredInMap GlobalUnitInfoMap
knownInfos UnitInfo
pkg =
  let
    upd_wired_in_pkg :: uid
-> GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo srcpkgid srcpkgname uid modulename mod
upd_wired_in_pkg uid
wiredInUnitId GenericUnitInfo srcpkgid srcpkgname uid modulename mod
pkg =
      GenericUnitInfo srcpkgid srcpkgname uid modulename mod
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 :: UnitInfo -> UnitInfo
upd_deps UnitInfo
pkg = UnitInfo
pkg {
          unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg),
          unitExposedModules
            = map (\(ModuleName
k,Maybe Module
v) -> (ModuleName
k, (Module -> Module) -> Maybe Module -> Maybe Module
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WireMap -> Module -> Module
updateWiredInUnitIdInModule WireMap
wiredInMap) Maybe Module
v))
                  (unitExposedModules pkg)
        }

    -- First check whether this is a wired-in unit.
    -- If it is, we need to use the wired-in 'UnitId' for looking up the UnitInfo in the
    -- 'GlobalUnitInfoMap'. We also update the 'UnitInfo' to use the wired-in unitId, as that's
    -- how we are going to use it, if it isn't already present in the 'GlobalUnitInfoMap'.
    -- Otherwise, we simply look up the 'UnitInfo' in the 'GlobalUnitInfoMap'.
    (UnitInfo
candidatePkg, GlobalUnitKey
key) =
      case UnitId -> WireMap -> Maybe UnitId
lookupWireMap (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
pkg) WireMap
wiredInMap of
        Just UnitId
wiredIn -> (UnitId -> UnitInfo -> UnitInfo
forall {uid} {srcpkgid} {srcpkgname} {modulename} {mod}.
uid
-> GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo srcpkgid srcpkgname uid modulename mod
upd_wired_in_pkg UnitId
wiredIn UnitInfo
pkg, UnitId -> UnitAbiHash -> GlobalUnitKey
mkGlobalUnitKey UnitId
wiredIn (UnitInfo -> UnitAbiHash
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> UnitAbiHash
unitAbiHash UnitInfo
pkg))
        Maybe UnitId
Nothing      -> (UnitInfo
pkg, UnitInfo -> GlobalUnitKey
globalUnitKeyFromUnitInfo UnitInfo
pkg)
  in
    -- If the UnitInfo is not already present in the 'GlobalUnitInfoMap', we need to update
    -- all references to wired-in units.
    case GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo
lookupGlobalUnitInfoMap GlobalUnitKey
key GlobalUnitInfoMap
knownInfos of
      Just UnitInfo
ui -> UnitInfo -> Either UnitInfo UnitInfo
forall a b. b -> Either a b
Right UnitInfo
ui
      Maybe UnitInfo
Nothing -> UnitInfo -> Either UnitInfo UnitInfo
forall a b. a -> Either a b
Left (UnitInfo -> UnitInfo
upd_deps UnitInfo
candidatePkg)

-- 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 :: WireMap -> Module -> Module
updateWiredInUnitIdInModule WireMap
wiredInMap (Module Unit
uid ModuleName
m) = Unit -> ModuleName -> Module
forall unit. unit -> ModuleName -> GenModule unit
Module (WireMap -> Unit -> Unit
upd_wired_in_uid WireMap
wiredInMap Unit
uid) ModuleName
m

upd_wired_in_uid :: WireMap -> Unit -> Unit
upd_wired_in_uid :: WireMap -> Unit -> Unit
upd_wired_in_uid WireMap
wiredInMap Unit
u = case Unit
u of
   Unit
HoleUnit -> Unit
forall uid. GenUnit uid
HoleUnit
   RealUnit (Definite UnitId
uid) -> Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite (WireMap -> UnitId -> UnitId
upd_wired_in WireMap
wiredInMap UnitId
uid))
   VirtUnit GenInstantiatedUnit UnitId
indef_uid ->
      GenInstantiatedUnit UnitId -> Unit
GenInstantiatedUnit UnitId -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit (GenInstantiatedUnit UnitId -> Unit)
-> GenInstantiatedUnit UnitId -> Unit
forall a b. (a -> b) -> a -> b
$ UnitId -> GenInstantiations UnitId -> GenInstantiatedUnit UnitId
forall u.
IsUnitId u =>
u -> GenInstantiations u -> GenInstantiatedUnit u
mkInstantiatedUnit
        (GenInstantiatedUnit UnitId -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf GenInstantiatedUnit UnitId
indef_uid)
        (((ModuleName, Module) -> (ModuleName, Module))
-> GenInstantiations UnitId -> GenInstantiations UnitId
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
x,Module
y) -> (ModuleName
x,WireMap -> Module -> Module
updateWiredInUnitIdInModule WireMap
wiredInMap Module
y)) (GenInstantiatedUnit UnitId -> GenInstantiations UnitId
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit UnitId
indef_uid))

upd_wired_in :: WireMap -> UnitId -> UnitId
upd_wired_in :: WireMap -> UnitId -> UnitId
upd_wired_in WireMap
wiredInMap UnitId
key
    | Just UnitId
key' <- UnitId -> WireMap -> Maybe UnitId
lookupWireMap UnitId
key WireMap
wiredInMap = UnitId
key'
    | Bool
otherwise = UnitId
key

-- -----------------------------------------------------------------------------
-- Reading the unit database(s) into the 'UnitIndexCache'

readUnitDatabases :: Logger -> UnitIndexCache -> UnitDbConfig -> IO [UnitDatabase UnitId]
readUnitDatabases :: Logger
-> UnitIndexCache -> UnitDbConfig -> IO [UnitDatabase UnitId]
readUnitDatabases Logger
logger UnitIndexCache
db_cache UnitDbConfig
cfg = do
  conf_refs <- UnitDbConfig -> IO [PkgDbRef]
getUnitDbRefs UnitDbConfig
cfg
  confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
  mapM (readOrGetUnitDatabase logger db_cache cfg) confs

-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location.
readOrGetUnitDatabase :: Logger -> UnitIndexCache -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
readOrGetUnitDatabase :: Logger
-> UnitIndexCache
-> UnitDbConfig
-> OsPath
-> IO (UnitDatabase UnitId)
readOrGetUnitDatabase Logger
logger UnitIndexCache
db_cache UnitDbConfig
cfg OsPath
conf_file =
  UnitIndexCache -> OsPath -> IO (Maybe (UnitDatabase UnitId))
readExternalUnitDatabase UnitIndexCache
db_cache OsPath
conf_file IO (Maybe (UnitDatabase UnitId))
-> (Maybe (UnitDatabase UnitId) -> IO (UnitDatabase UnitId))
-> IO (UnitDatabase UnitId)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
    Maybe (UnitDatabase UnitId)
Nothing -> do
      new_db <- Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
readUnitDatabase Logger
logger UnitDbConfig
cfg OsPath
conf_file
      cacheExternalUnitDatabase db_cache new_db
      pure new_db
    Just UnitDatabase UnitId
db ->
      UnitDatabase UnitId -> IO (UnitDatabase UnitId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnitDatabase UnitId
db