module GHC.Unit.External.Database (
  -- * 'ExternalUnitDatabases'
  ExternalUnitDatabases,
  emptyExternalUnitDatabases,
  insertExternalUnitDatabases,
  deleteExternalUnitDatabases,
  lookupExternalUnitDatabases,
  -- * 'UnitDatabase' and how to merge them.
  UnitDatabase (..),
  mergeDatabases,
  UnitPrecedenceMap,
  sortByPreference,
  compareByPreference,
  -- * Reading packages from disk.
  UnitDbConfig (..),
  readUnitDatabase,
  getUnitDbRefs,
  resolveUnitDatabase,
) where

import GHC.Prelude

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.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 Control.Monad
import Data.Char
import Data.List (sortBy)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as 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

-- ----------------------------------------------------------------------------
-- ExternalUnitDatabases
-- ----------------------------------------------------------------------------

-- | Caches unit databases in-memory.
data ExternalUnitDatabases unit = ExternalUnitDatabases
  { forall unit.
ExternalUnitDatabases unit -> Map OsPath (UnitDatabase unit)
eud_cachedDatabases :: !(Map OsPath (UnitDatabase unit))
  }

emptyExternalUnitDatabases :: ExternalUnitDatabases unit
emptyExternalUnitDatabases :: forall unit. ExternalUnitDatabases unit
emptyExternalUnitDatabases =
  ExternalUnitDatabases
    { eud_cachedDatabases :: Map OsPath (UnitDatabase unit)
eud_cachedDatabases = Map OsPath (UnitDatabase unit)
forall k a. Map k a
Map.empty
    }

insertExternalUnitDatabases :: UnitDatabase unit -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit
insertExternalUnitDatabases :: forall unit.
UnitDatabase unit
-> ExternalUnitDatabases unit -> ExternalUnitDatabases unit
insertExternalUnitDatabases UnitDatabase unit
unit_db ExternalUnitDatabases unit
eud =
  ExternalUnitDatabases
    { eud_cachedDatabases :: Map OsPath (UnitDatabase unit)
eud_cachedDatabases = OsPath
-> UnitDatabase unit
-> Map OsPath (UnitDatabase unit)
-> Map OsPath (UnitDatabase unit)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitDatabase unit -> OsPath
forall unit. UnitDatabase unit -> OsPath
unitDatabasePath UnitDatabase unit
unit_db) UnitDatabase unit
unit_db (ExternalUnitDatabases unit -> Map OsPath (UnitDatabase unit)
forall unit.
ExternalUnitDatabases unit -> Map OsPath (UnitDatabase unit)
eud_cachedDatabases ExternalUnitDatabases unit
eud)
    }

deleteExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit
deleteExternalUnitDatabases :: forall unit.
OsPath -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit
deleteExternalUnitDatabases OsPath
unit_db_path ExternalUnitDatabases unit
eud =
  ExternalUnitDatabases
    { eud_cachedDatabases :: Map OsPath (UnitDatabase unit)
eud_cachedDatabases = OsPath
-> Map OsPath (UnitDatabase unit) -> Map OsPath (UnitDatabase unit)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete OsPath
unit_db_path (ExternalUnitDatabases unit -> Map OsPath (UnitDatabase unit)
forall unit.
ExternalUnitDatabases unit -> Map OsPath (UnitDatabase unit)
eud_cachedDatabases ExternalUnitDatabases unit
eud)
    }

lookupExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> Maybe (UnitDatabase unit)
lookupExternalUnitDatabases :: forall unit.
OsPath -> ExternalUnitDatabases unit -> Maybe (UnitDatabase unit)
lookupExternalUnitDatabases OsPath
key ExternalUnitDatabases unit
eud =
  OsPath
-> Map OsPath (UnitDatabase unit) -> Maybe (UnitDatabase unit)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup OsPath
key (ExternalUnitDatabases unit -> Map OsPath (UnitDatabase unit)
forall unit.
ExternalUnitDatabases unit -> Map OsPath (UnitDatabase unit)
eud_cachedDatabases ExternalUnitDatabases unit
eud)

-- ----------------------------------------------------------------------------
-- UnitDatabase
-- ----------------------------------------------------------------------------

-- | Unit database entry.
data UnitDatabase unit = UnitDatabase
  { forall unit. UnitDatabase unit -> OsPath
unitDatabasePath :: OsPath
  , forall unit. UnitDatabase unit -> [GenUnitInfo unit]
unitDatabaseUnits :: [GenUnitInfo unit]
  }

instance (Outputable u) => Outputable (UnitDatabase u) where
  ppr :: UnitDatabase u -> SDoc
ppr (UnitDatabase OsPath
fp [GenUnitInfo u]
_u) = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"DB:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OsPath -> SDoc
forall a. Outputable a => a -> SDoc
ppr OsPath
fp

-- ----------------------------------------------------------------------------
--
-- 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
-> [UnitDatabase UnitId] -> IO (UnitInfoMap, UnitPrecedenceMap)
mergeDatabases Logger
logger = ((UnitInfoMap, UnitPrecedenceMap)
 -> (Int, UnitDatabase UnitId)
 -> IO (UnitInfoMap, UnitPrecedenceMap))
-> (UnitInfoMap, UnitPrecedenceMap)
-> [(Int, UnitDatabase UnitId)]
-> IO (UnitInfoMap, UnitPrecedenceMap)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (UnitInfoMap, UnitPrecedenceMap)
-> (Int, UnitDatabase UnitId)
-> IO (UnitInfoMap, UnitPrecedenceMap)
merge (UnitInfoMap
forall k a. UniqMap k a
emptyUniqMap, UnitPrecedenceMap
forall k a. UniqMap k a
emptyUniqMap) ([(Int, UnitDatabase UnitId)]
 -> IO (UnitInfoMap, UnitPrecedenceMap))
-> ([UnitDatabase UnitId] -> [(Int, UnitDatabase UnitId)])
-> [UnitDatabase UnitId]
-> IO (UnitInfoMap, UnitPrecedenceMap)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [UnitDatabase UnitId] -> [(Int, UnitDatabase UnitId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..]
  where
    merge :: (UnitInfoMap, UnitPrecedenceMap)
-> (Int, UnitDatabase UnitId)
-> IO (UnitInfoMap, UnitPrecedenceMap)
merge (UnitInfoMap
pkg_map, UnitPrecedenceMap
prec_map) (Int
i, UnitDatabase OsPath
db_path [GenUnitInfo UnitId]
db) = do
      Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"loading package database" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OsPath -> SDoc
forall a. Outputable a => a -> SDoc
ppr OsPath
db_path
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [UnitId] -> (UnitId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
override_set) ((UnitId -> IO ()) -> IO ()) -> (UnitId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UnitId
pkg ->
            Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"package" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
pkg SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"overrides a previously defined package"
      (UnitInfoMap, UnitPrecedenceMap)
-> IO (UnitInfoMap, UnitPrecedenceMap)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfoMap
pkg_map', UnitPrecedenceMap
prec_map')
     where
      db_map :: UnitInfoMap
db_map = [GenUnitInfo UnitId] -> UnitInfoMap
forall {srcpkgid} {srcpkgname} {modulename} {mod}.
[GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod]
-> UniqMap
     UnitId (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)
mk_pkg_map [GenUnitInfo UnitId]
db
      mk_pkg_map :: [GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod]
-> UniqMap
     UnitId (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)
mk_pkg_map = [(UnitId,
  GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)]
-> UniqMap
     UnitId (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ([(UnitId,
   GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)]
 -> UniqMap
      UnitId (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod))
-> ([GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod]
    -> [(UnitId,
         GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)])
-> [GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod]
-> UniqMap
     UnitId (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
 -> (UnitId,
     GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod))
-> [GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod]
-> [(UnitId,
     GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)]
forall a b. (a -> b) -> [a] -> [b]
map (\GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
p -> (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
p, GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
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 UnitId
override_set = Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (UnitInfoMap -> Set UnitId
forall k a. Ord k => UniqMap k a -> Set k
nonDetUniqMapToKeySet UnitInfoMap
db_map)
                                      (UnitInfoMap -> Set UnitId
forall k a. Ord k => UniqMap k a -> Set k
nonDetUniqMapToKeySet UnitInfoMap
pkg_map)

      -- Now merge the sets together (NB: in case of duplicate,
      -- first argument preferred)
      pkg_map' :: UnitInfoMap
      pkg_map' :: UnitInfoMap
pkg_map' = UnitInfoMap
pkg_map UnitInfoMap -> UnitInfoMap -> UnitInfoMap
forall k a. UniqMap k a -> UniqMap k a -> UniqMap k a
`plusUniqMap` UnitInfoMap
db_map

      prec_map' :: UnitPrecedenceMap
      prec_map' :: UnitPrecedenceMap
prec_map' = UnitPrecedenceMap
prec_map UnitPrecedenceMap -> UnitPrecedenceMap -> UnitPrecedenceMap
forall k a. UniqMap k a -> UniqMap k a -> UniqMap k a
`plusUniqMap` ((GenUnitInfo UnitId -> Int) -> UnitInfoMap -> UnitPrecedenceMap
forall a b k. (a -> b) -> UniqMap k a -> UniqMap k b
mapUniqMap (Int -> GenUnitInfo UnitId -> Int
forall a b. a -> b -> a
const Int
i) UnitInfoMap
db_map)

-- | This sorts a list of packages, putting "preferred" packages first.
-- See 'compareByPreference' for the semantics of "preference".
sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference :: UnitPrecedenceMap -> [GenUnitInfo UnitId] -> [GenUnitInfo UnitId]
sortByPreference UnitPrecedenceMap
prec_map = (GenUnitInfo UnitId -> GenUnitInfo UnitId -> Ordering)
-> [GenUnitInfo UnitId] -> [GenUnitInfo UnitId]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((GenUnitInfo UnitId -> GenUnitInfo UnitId -> Ordering)
-> GenUnitInfo UnitId -> GenUnitInfo UnitId -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (UnitPrecedenceMap
-> GenUnitInfo UnitId -> GenUnitInfo UnitId -> Ordering
compareByPreference UnitPrecedenceMap
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 :: UnitPrecedenceMap
-> GenUnitInfo UnitId -> GenUnitInfo UnitId -> Ordering
compareByPreference UnitPrecedenceMap
prec_map GenUnitInfo UnitId
pkg GenUnitInfo UnitId
pkg'
  = case (GenUnitInfo UnitId -> Version)
-> GenUnitInfo UnitId -> GenUnitInfo UnitId -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing GenUnitInfo UnitId -> Version
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Version
unitPackageVersion GenUnitInfo UnitId
pkg GenUnitInfo UnitId
pkg' of
        Ordering
GT -> Ordering
GT
        Ordering
EQ | Just Int
prec  <- UnitPrecedenceMap -> UnitId -> Maybe Int
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitPrecedenceMap
prec_map (GenUnitInfo UnitId -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenUnitInfo UnitId
pkg)
           , Just Int
prec' <- UnitPrecedenceMap -> UnitId -> Maybe Int
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitPrecedenceMap
prec_map (GenUnitInfo UnitId -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenUnitInfo UnitId
pkg')
           -- Prefer the unit from the later DB flag (i.e., higher
           -- precedence)
           -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
prec Int
prec'
           | Bool
otherwise
           -> Ordering
EQ
        Ordering
LT -> Ordering
LT

-- -----------------------------------------------------------------------------
-- Reading the unit database(s)

data UnitDbConfig = UnitDbConfig
  { UnitDbConfig -> [PackageDBFlag]
unitDbConfigFlagsDB :: [PackageDBFlag]
  , UnitDbConfig -> [Char]
unitDbConfigProgramName :: String
  , UnitDbConfig -> [Char]
unitDbConfigDBName :: FilePath
  , UnitDbConfig -> ArchOS
unitDbConfigPlatformArchOS :: ArchOS
  , UnitDbConfig -> [Char]
unitDbConfigGlobalDB :: FilePath
  , UnitDbConfig -> [Char]
unitDbConfigGHCDir :: FilePath
  }

getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef]
getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef]
getUnitDbRefs UnitDbConfig
cfg = do
  let system_conf_refs :: [PkgDbRef]
system_conf_refs = [PkgDbRef
UserPkgDb, PkgDbRef
GlobalPkgDb]

  e_pkg_path <- IO [Char] -> IO (Either IOException [Char])
forall a. IO a -> IO (Either IOException a)
tryIO ([Char] -> IO [Char]
getEnv ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (UnitDbConfig -> [Char]
unitDbConfigProgramName UnitDbConfig
cfg) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_PACKAGE_PATH")
  let base_conf_refs = case Either IOException [Char]
e_pkg_path of
        Left IOException
_ -> [PkgDbRef]
system_conf_refs
        Right [Char]
path
         | Just ([Char]
xs, Char
x) <- [Char] -> Maybe ([Char], Char)
forall a. [a] -> Maybe ([a], a)
snocView [Char]
path, Char -> Bool
isSearchPathSeparator Char
x
         -> (OsPath -> PkgDbRef) -> [OsPath] -> [PkgDbRef]
forall a b. (a -> b) -> [a] -> [b]
map OsPath -> PkgDbRef
PkgDbPath (OsPath -> [OsPath]
OsPath.splitSearchPath (HasCallStack => [Char] -> OsPath
[Char] -> OsPath
OsPath.unsafeEncodeUtf [Char]
xs)) [PkgDbRef] -> [PkgDbRef] -> [PkgDbRef]
forall a. [a] -> [a] -> [a]
++ [PkgDbRef]
system_conf_refs
         | Bool
otherwise
         -> (OsPath -> PkgDbRef) -> [OsPath] -> [PkgDbRef]
forall a b. (a -> b) -> [a] -> [b]
map OsPath -> PkgDbRef
PkgDbPath (OsPath -> [OsPath]
OsPath.splitSearchPath (HasCallStack => [Char] -> OsPath
[Char] -> OsPath
OsPath.unsafeEncodeUtf [Char]
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 :: PackageDBFlag -> [PkgDbRef] -> [PkgDbRef]
doFlag (PackageDB PkgDbRef
p) [PkgDbRef]
dbs = PkgDbRef
p PkgDbRef -> [PkgDbRef] -> [PkgDbRef]
forall a. a -> [a] -> [a]
: [PkgDbRef]
dbs
  doFlag PackageDBFlag
NoUserPackageDB [PkgDbRef]
dbs = (PkgDbRef -> Bool) -> [PkgDbRef] -> [PkgDbRef]
forall a. (a -> Bool) -> [a] -> [a]
filter PkgDbRef -> Bool
isNotUser [PkgDbRef]
dbs
  doFlag PackageDBFlag
NoGlobalPackageDB [PkgDbRef]
dbs = (PkgDbRef -> Bool) -> [PkgDbRef] -> [PkgDbRef]
forall a. (a -> Bool) -> [a] -> [a]
filter PkgDbRef -> Bool
isNotGlobal [PkgDbRef]
dbs
  doFlag PackageDBFlag
ClearPackageDBs [PkgDbRef]
_ = []

  isNotUser :: PkgDbRef -> Bool
isNotUser PkgDbRef
UserPkgDb = Bool
False
  isNotUser PkgDbRef
_ = Bool
True

  isNotGlobal :: PkgDbRef -> Bool
isNotGlobal PkgDbRef
GlobalPkgDb = Bool
False
  isNotGlobal PkgDbRef
_ = Bool
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 :: UnitDbConfig -> PkgDbRef -> IO (Maybe OsPath)
resolveUnitDatabase UnitDbConfig
cfg PkgDbRef
GlobalPkgDb = Maybe OsPath -> IO (Maybe OsPath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OsPath -> IO (Maybe OsPath))
-> Maybe OsPath -> IO (Maybe OsPath)
forall a b. (a -> b) -> a -> b
$ OsPath -> Maybe OsPath
forall a. a -> Maybe a
Just (OsPath -> Maybe OsPath) -> OsPath -> Maybe OsPath
forall a b. (a -> b) -> a -> b
$ HasCallStack => [Char] -> OsPath
[Char] -> OsPath
OsPath.unsafeEncodeUtf ([Char] -> OsPath) -> [Char] -> OsPath
forall a b. (a -> b) -> a -> b
$ UnitDbConfig -> [Char]
unitDbConfigGlobalDB UnitDbConfig
cfg
resolveUnitDatabase UnitDbConfig
cfg PkgDbRef
UserPkgDb = MaybeT IO OsPath -> IO (Maybe OsPath)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO OsPath -> IO (Maybe OsPath))
-> MaybeT IO OsPath -> IO (Maybe OsPath)
forall a b. (a -> b) -> a -> b
$ do
  dir <- [Char] -> ArchOS -> MaybeT IO [Char]
versionedAppDir (UnitDbConfig -> [Char]
unitDbConfigProgramName UnitDbConfig
cfg) (UnitDbConfig -> ArchOS
unitDbConfigPlatformArchOS UnitDbConfig
cfg)
  let pkgconf = [Char]
dir [Char] -> [Char] -> [Char]
</> UnitDbConfig -> [Char]
unitDbConfigDBName UnitDbConfig
cfg
  exist <- tryMaybeT $ doesDirectoryExist pkgconf
  if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero
resolveUnitDatabase UnitDbConfig
_ (PkgDbPath OsPath
name) = Maybe OsPath -> IO (Maybe OsPath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OsPath -> IO (Maybe OsPath))
-> Maybe OsPath -> IO (Maybe OsPath)
forall a b. (a -> b) -> a -> b
$ OsPath -> Maybe OsPath
forall a. a -> Maybe a
Just OsPath
name

-- | Read the 'UnitDatabase' at the given location.
readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
readUnitDatabase Logger
logger UnitDbConfig
cfg OsPath
conf_file = do
  isdir <- OsPath -> IO Bool
OsPath.doesDirectoryExist OsPath
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 [DbUnitInfo]
pkgs -> [DbUnitInfo] -> IO [DbUnitInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [DbUnitInfo]
pkgs
                   Maybe [DbUnitInfo]
Nothing   -> GhcException -> IO [DbUnitInfo]
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO [DbUnitInfo])
-> GhcException -> IO [DbUnitInfo]
forall a b. (a -> b) -> a -> b
$ [Char] -> GhcException
InstallationError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$
                      [Char]
"ghc no longer supports single-file style package " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                      [Char]
"databases (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OsPath -> [Char]
forall a. Show a => a -> [Char]
show OsPath
conf_file [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                      [Char]
") use 'ghc-pkg init' to create the database with " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                      [Char]
"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 -> OsPath
OsPath.dropTrailingPathSeparator OsPath
conf_file
      top_dir = HasCallStack => [Char] -> OsPath
[Char] -> OsPath
OsPath.unsafeEncodeUtf (UnitDbConfig -> [Char]
unitDbConfigGHCDir UnitDbConfig
cfg)
      pkgroot = OsPath -> OsPath
OsPath.takeDirectory OsPath
conf_file'
      pkg_configs1 = (DbUnitInfo -> GenUnitInfo UnitId)
-> [DbUnitInfo] -> [GenUnitInfo UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (OsPath -> OsPath -> GenUnitInfo UnitId -> GenUnitInfo UnitId
mungeUnitInfo OsPath
top_dir OsPath
pkgroot (GenUnitInfo UnitId -> GenUnitInfo UnitId)
-> (DbUnitInfo -> GenUnitInfo UnitId)
-> DbUnitInfo
-> GenUnitInfo UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitKey -> UnitId) -> GenUnitInfo UnitKey -> GenUnitInfo UnitId
forall v u.
IsUnitId v =>
(u -> v) -> GenUnitInfo u -> GenUnitInfo v
mapUnitInfo (\(UnitKey FastString
x) -> FastString -> UnitId
UnitId FastString
x) (GenUnitInfo UnitKey -> GenUnitInfo UnitId)
-> (DbUnitInfo -> GenUnitInfo UnitKey)
-> DbUnitInfo
-> GenUnitInfo UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbUnitInfo -> GenUnitInfo UnitKey
mkUnitKeyInfo)
                         [DbUnitInfo]
proto_pkg_configs
  --
  return $ UnitDatabase conf_file' pkg_configs1
  where
    readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
    readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
readDirStyleUnitInfo OsPath
conf_dir = do
      let filename :: OsPath
filename = OsPath
conf_dir OsPath -> OsPath -> OsPath
OsPath.</> (HasCallStack => [Char] -> OsPath
[Char] -> OsPath
OsPath.unsafeEncodeUtf [Char]
"package.cache")
      cache_exists <- OsPath -> IO Bool
OsPath.doesFileExist OsPath
filename
      if cache_exists
        then do
          debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename
          readPackageDbForGhc (OsPath.unsafeDecodeUtf 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 :: IO (Maybe [DbUnitInfo])
tryReadOldFileStyleUnitInfo = do
      content <- [Char] -> IO [Char]
readFile (HasCallStack => OsPath -> [Char]
OsPath -> [Char]
OsPath.unsafeDecodeUtf OsPath
conf_file) IO [Char] -> (IOException -> IO [Char]) -> IO [Char]
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
      if take 2 content == "[]"
        then do
          let conf_dir = OsPath
conf_file OsPath -> OsPath -> OsPath
OsPath.<.> HasCallStack => [Char] -> OsPath
[Char] -> OsPath
OsPath.unsafeEncodeUtf [Char]
"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 :: OsPath -> OsPath -> GenUnitInfo UnitId -> GenUnitInfo UnitId
mungeUnitInfo OsPath
top_dir OsPath
pkgroot =
    GenUnitInfo UnitId -> GenUnitInfo UnitId
mungeDynLibFields
  (GenUnitInfo UnitId -> GenUnitInfo UnitId)
-> (GenUnitInfo UnitId -> GenUnitInfo UnitId)
-> GenUnitInfo UnitId
-> GenUnitInfo UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePathST
-> FilePathST -> GenUnitInfo UnitId -> GenUnitInfo UnitId
forall a b c d e.
FilePathST
-> FilePathST
-> GenericUnitInfo a b c d e
-> GenericUnitInfo a b c d e
mungeUnitInfoPaths ([Char] -> FilePathST
ST.pack (HasCallStack => OsPath -> [Char]
OsPath -> [Char]
OsPath.unsafeDecodeUtf OsPath
top_dir)) ([Char] -> FilePathST
ST.pack (HasCallStack => OsPath -> [Char]
OsPath -> [Char]
OsPath.unsafeDecodeUtf OsPath
pkgroot))

mungeDynLibFields :: UnitInfo -> UnitInfo
mungeDynLibFields :: GenUnitInfo UnitId -> GenUnitInfo UnitId
mungeDynLibFields GenUnitInfo UnitId
pkg =
    GenUnitInfo UnitId
pkg {
      unitLibraryDynDirs = case unitLibraryDynDirs pkg of
         [] -> GenUnitInfo UnitId -> [FilePathST]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [FilePathST]
unitLibraryDirs GenUnitInfo UnitId
pkg
         [FilePathST]
ds -> [FilePathST]
ds
    }