module GHC.Unit.External.Wired (
  -- * 'WireMap'
  WireMap,
  emptyWireMap,
  isWireMapEmpty,
  lookupWireMap,
  listWireMap,
  -- * 'UnwireMap'
  UnwireMap,
  emptyUnwireMap,
  lookupUnwireMap,
  unwiringMapFromWireMap,
  -- * Creating 'WireMap'
  findWiredInUnits,
) where

import GHC.Prelude

import GHC.Unit.External.Database
import GHC.Unit.External.Visibility

import GHC.Data.Maybe
import GHC.Types.Unique.Map
import GHC.Unit.Database
import GHC.Unit.Info
import GHC.Unit.Types
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Outputable as Outputable

-- | The 'WireMap' records the mapping from the 'UnitId' of on-disk 'UnitInfo'
-- to the 'UnitId' of the 'wiredInMap'.
--
-- See 'wiredInUnitIds' for the set of wired-in units.
--
newtype WireMap =
  WireMap (UniqMap UnitId UnitId)

emptyWireMap :: WireMap
emptyWireMap :: WireMap
emptyWireMap = UniqMap UnitId UnitId -> WireMap
WireMap UniqMap UnitId UnitId
forall k a. UniqMap k a
emptyUniqMap

isWireMapEmpty :: WireMap -> Bool
isWireMapEmpty :: WireMap -> Bool
isWireMapEmpty (WireMap UniqMap UnitId UnitId
wmap) = UniqMap UnitId UnitId -> Bool
forall k a. UniqMap k a -> Bool
isNullUniqMap UniqMap UnitId UnitId
wmap

lookupWireMap :: UnitId -> WireMap -> Maybe UnitId
lookupWireMap :: UnitId -> WireMap -> Maybe UnitId
lookupWireMap UnitId
uid (WireMap UniqMap UnitId UnitId
wmap) = UniqMap UnitId UnitId -> UnitId -> Maybe UnitId
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap UnitId UnitId
wmap UnitId
uid

listWireMap :: WireMap -> [(UnitId, UnitId)]
listWireMap :: WireMap -> [(UnitId, UnitId)]
listWireMap (WireMap UniqMap UnitId UnitId
wmap) = UniqMap UnitId UnitId -> [(UnitId, UnitId)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap UnitId UnitId
wmap

-- | The reverse of 'WireMap'.
-- Records the mapping from the wired-in 'UnitId' to the on-disk 'UnitId'.
newtype UnwireMap =
  UnwireMap (UniqMap UnitId UnitId)

emptyUnwireMap :: UnwireMap
emptyUnwireMap :: UnwireMap
emptyUnwireMap = UniqMap UnitId UnitId -> UnwireMap
UnwireMap UniqMap UnitId UnitId
forall k a. UniqMap k a
emptyUniqMap

unwiringMapFromWireMap :: WireMap -> UnwireMap
unwiringMapFromWireMap :: WireMap -> UnwireMap
unwiringMapFromWireMap (WireMap UniqMap UnitId UnitId
wired_map) =
  UniqMap UnitId UnitId -> UnwireMap
UnwireMap (UniqMap UnitId UnitId -> UnwireMap)
-> UniqMap UnitId UnitId -> UnwireMap
forall a b. (a -> b) -> a -> b
$ [(UnitId, UnitId)] -> UniqMap UnitId UnitId
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap [ (UnitId
v,UnitId
k) | (UnitId
k,UnitId
v) <- UniqMap UnitId UnitId -> [(UnitId, UnitId)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap UnitId UnitId
wired_map ]

lookupUnwireMap :: UnitId -> UnwireMap -> Maybe UnitId
lookupUnwireMap :: UnitId -> UnwireMap -> Maybe UnitId
lookupUnwireMap UnitId
uid (UnwireMap UniqMap UnitId UnitId
wmap) = UniqMap UnitId UnitId -> UnitId -> Maybe UnitId
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap UnitId UnitId
wmap UnitId
uid

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

findWiredInUnits
   :: Logger
   -> UnitPrecedenceMap
   -> [UnitInfo]           -- database
   -> VisibilityMap             -- info on what units are visible
                                -- for wired in selection
   -> IO WireMap   -- map from unit id to wired identity
findWiredInUnits :: Logger
-> UnitPrecedenceMap -> [UnitInfo] -> VisibilityMap -> IO WireMap
findWiredInUnits Logger
logger UnitPrecedenceMap
prec_map [UnitInfo]
pkgs VisibilityMap
vis_map = do
  -- Now we must find our wired-in units, and rename them to
  -- their canonical names (eg. base-1.0 ==> base), as described
  -- in Note [Wired-in units] in GHC.Unit.Types
  let
        matches :: UnitInfo -> UnitId -> Bool
        UnitInfo
pc matches :: UnitInfo -> UnitId -> Bool
`matches` UnitId
pid = UnitInfo -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
pc PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> PackageName
PackageName (UnitId -> FastString
unitIdFS UnitId
pid)

        -- find which package corresponds to each wired-in package
        -- delete any other packages with the same name
        -- update the package and any dependencies to point to the new
        -- one.
        --
        -- When choosing which package to map to a wired-in package
        -- name, we try to pick the latest version of exposed packages.
        -- However, if there are no exposed wired in packages available
        -- (e.g. -hide-all-packages was used), we can't bail: we *have*
        -- to assign a package for the wired-in package: so we try again
        -- with hidden packages included to (and pick the latest
        -- version).
        --
        -- You can also override the default choice by using -ignore-package:
        -- this works even when there is no exposed wired in package
        -- available.
        --
        findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
        findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
findWiredInUnit [UnitInfo]
pkgs UnitId
wired_pkg = [IO (Maybe (UnitId, UnitInfo))] -> IO (Maybe (UnitId, UnitInfo))
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Foldable f) =>
f (m (Maybe a)) -> m (Maybe a)
firstJustsM [[UnitInfo] -> IO (Maybe (UnitId, UnitInfo))
try [UnitInfo]
all_exposed_ps, [UnitInfo] -> IO (Maybe (UnitId, UnitInfo))
try [UnitInfo]
all_ps, IO (Maybe (UnitId, UnitInfo))
notfound]
          where
                all_ps :: [UnitInfo]
all_ps = [ UnitInfo
p | UnitInfo
p <- [UnitInfo]
pkgs, UnitInfo
p UnitInfo -> UnitId -> Bool
`matches` UnitId
wired_pkg ]
                all_exposed_ps :: [UnitInfo]
all_exposed_ps = [ UnitInfo
p | UnitInfo
p <- [UnitInfo]
all_ps, (UnitInfo -> Unit
mkUnit UnitInfo
p) Unit -> VisibilityMap -> Bool
forall k a. Uniquable k => k -> UniqMap k a -> Bool
`elemUniqMap` VisibilityMap
vis_map ]

                try :: [UnitInfo] -> IO (Maybe (UnitId, UnitInfo))
try [UnitInfo]
ps = case UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map [UnitInfo]
ps of
                    UnitInfo
p:[UnitInfo]
_ -> (UnitId, UnitInfo) -> Maybe (UnitId, UnitInfo)
forall a. a -> Maybe a
Just ((UnitId, UnitInfo) -> Maybe (UnitId, UnitInfo))
-> IO (UnitId, UnitInfo) -> IO (Maybe (UnitId, UnitInfo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitInfo -> IO (UnitId, UnitInfo)
pick UnitInfo
p
                    [UnitInfo]
_ -> Maybe (UnitId, UnitInfo) -> IO (Maybe (UnitId, UnitInfo))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (UnitId, UnitInfo)
forall a. Maybe a
Nothing

                notfound :: IO (Maybe (UnitId, UnitInfo))
notfound = do
                          Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"wired-in package "
                                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (UnitId -> FastString
unitIdFS UnitId
wired_pkg)
                                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" not found."
                          Maybe (UnitId, UnitInfo) -> IO (Maybe (UnitId, UnitInfo))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (UnitId, UnitInfo)
forall a. Maybe a
Nothing
                pick :: UnitInfo -> IO (UnitId, UnitInfo)
                pick :: UnitInfo -> IO (UnitId, UnitInfo)
pick UnitInfo
pkg = do
                        Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"wired-in package "
                                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (UnitId -> FastString
unitIdFS UnitId
wired_pkg)
                                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" mapped to "
                                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
pkg)
                        (UnitId, UnitInfo) -> IO (UnitId, UnitInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId
wired_pkg, UnitInfo
pkg)


  mb_wired_in_pkgs <- (UnitId -> IO (Maybe (UnitId, UnitInfo)))
-> [UnitId] -> IO [Maybe (UnitId, UnitInfo)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
findWiredInUnit [UnitInfo]
pkgs) [UnitId]
wiredInUnitIds
  let
        wired_in_pkgs = [Maybe (UnitId, UnitInfo)] -> [(UnitId, UnitInfo)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (UnitId, UnitInfo)]
mb_wired_in_pkgs

        wiredInMap :: UniqMap UnitId UnitId
        wiredInMap = [(UnitId, UnitId)] -> UniqMap UnitId UnitId
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap
          [ (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
realUnitInfo, UnitId
wiredInUnitId)
          | (UnitId
wiredInUnitId, UnitInfo
realUnitInfo) <- [(UnitId, UnitInfo)]
wired_in_pkgs
          , Bool -> Bool
not (UnitInfo -> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsIndefinite UnitInfo
realUnitInfo)
          ]

  return $ WireMap wiredInMap