{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.Build.Installed
( getInstalled
, toInstallMap
) where
import Data.Conduit ( ZipSink (..), getZipSink )
import qualified Data.Conduit.List as CL
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Stack.Build.Cache ( getInstalledExes )
import Stack.Constants ( wiredInPackages )
import Stack.PackageDump
( conduitDumpPackage, ghcPkgDump, pruneDeps )
import Stack.Prelude
import Stack.SourceMap ( getPLIVersion, loadVersion )
import Stack.Types.CompilerPaths ( getGhcPkgExe )
import Stack.Types.DumpPackage
( DumpPackage (..), SublibDump (..), dpParentLibIdent )
import Stack.Types.EnvConfig
( HasEnvConfig, packageDatabaseDeps, packageDatabaseExtra
, packageDatabaseLocal
)
import Stack.Types.GhcPkgId ( GhcPkgId )
import Stack.Types.Installed
( InstallLocation (..), InstallMap, Installed (..)
, InstalledLibraryInfo (..), InstalledMap
, InstalledPackageLocation (..), PackageDatabase (..)
, PackageDbVariety (..), toPackageDbVariety
)
import Stack.Types.SourceMap
( DepPackage (..), ProjectPackage (..), SourceMap (..) )
toInstallMap :: MonadIO m => SourceMap -> m InstallMap
toInstallMap :: forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap = do
InstallMap
projectInstalls <-
Map PackageName ProjectPackage
-> (ProjectPackage -> m (InstallLocation, Version)) -> m InstallMap
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for SourceMap
sourceMap.project ((ProjectPackage -> m (InstallLocation, Version)) -> m InstallMap)
-> (ProjectPackage -> m (InstallLocation, Version)) -> m InstallMap
forall a b. (a -> b) -> a -> b
$ \ProjectPackage
pp -> do
Version
version <- CommonPackage -> m Version
forall (m :: * -> *). MonadIO m => CommonPackage -> m Version
loadVersion ProjectPackage
pp.projectCommon
(InstallLocation, Version) -> m (InstallLocation, Version)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallLocation
Local, Version
version)
InstallMap
depInstalls <-
Map PackageName DepPackage
-> (DepPackage -> m (InstallLocation, Version)) -> m InstallMap
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for SourceMap
sourceMap.deps ((DepPackage -> m (InstallLocation, Version)) -> m InstallMap)
-> (DepPackage -> m (InstallLocation, Version)) -> m InstallMap
forall a b. (a -> b) -> a -> b
$ \DepPackage
dp ->
case DepPackage
dp.location of
PLImmutable PackageLocationImmutable
pli -> (InstallLocation, Version) -> m (InstallLocation, Version)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallLocation
Snap, PackageLocationImmutable -> Version
getPLIVersion PackageLocationImmutable
pli)
PLMutable ResolvedPath Dir
_ -> do
Version
version <- CommonPackage -> m Version
forall (m :: * -> *). MonadIO m => CommonPackage -> m Version
loadVersion DepPackage
dp.depCommon
(InstallLocation, Version) -> m (InstallLocation, Version)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallLocation
Local, Version
version)
InstallMap -> m InstallMap
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallMap -> m InstallMap) -> InstallMap -> m InstallMap
forall a b. (a -> b) -> a -> b
$ InstallMap
projectInstalls InstallMap -> InstallMap -> InstallMap
forall a. Semigroup a => a -> a -> a
<> InstallMap
depInstalls
getInstalled :: HasEnvConfig env
=> InstallMap
-> RIO env
( InstalledMap
, [DumpPackage]
, [DumpPackage]
, [DumpPackage]
)
getInstalled :: forall env.
HasEnvConfig env =>
InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap = do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Finding out which packages are already installed"
Path Abs Dir
snapDBPath <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseDeps
Path Abs Dir
localDBPath <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal
[Path Abs Dir]
extraDBPaths <- RIO env [Path Abs Dir]
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m) =>
m [Path Abs Dir]
packageDatabaseExtra
let loadDatabase' :: PackageDatabase
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' = InstallMap
-> PackageDatabase
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> PackageDatabase
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase InstallMap
installMap
([LoadHelper]
installedLibs0, [DumpPackage]
globalDumpPkgs) <- PackageDatabase
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' PackageDatabase
GlobalPkgDb []
([LoadHelper]
installedLibs1, [DumpPackage]
_extraInstalled) <-
(([LoadHelper], [DumpPackage])
-> Path Abs Dir -> RIO env ([LoadHelper], [DumpPackage]))
-> ([LoadHelper], [DumpPackage])
-> [Path Abs Dir]
-> RIO env ([LoadHelper], [DumpPackage])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\([LoadHelper], [DumpPackage])
lhs' Path Abs Dir
pkgdb ->
PackageDatabase
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' (InstalledPackageLocation -> Path Abs Dir -> PackageDatabase
UserPkgDb InstalledPackageLocation
ExtraPkgDb Path Abs Dir
pkgdb) (([LoadHelper], [DumpPackage]) -> [LoadHelper]
forall a b. (a, b) -> a
fst ([LoadHelper], [DumpPackage])
lhs')
) ([LoadHelper]
installedLibs0, [DumpPackage]
globalDumpPkgs) [Path Abs Dir]
extraDBPaths
([LoadHelper]
installedLibs2, [DumpPackage]
snapshotDumpPkgs) <-
PackageDatabase
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' (InstalledPackageLocation -> Path Abs Dir -> PackageDatabase
UserPkgDb (InstallLocation -> InstalledPackageLocation
InstalledTo InstallLocation
Snap) Path Abs Dir
snapDBPath) [LoadHelper]
installedLibs1
([LoadHelper]
installedLibs3, [DumpPackage]
localDumpPkgs) <-
PackageDatabase
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' (InstalledPackageLocation -> Path Abs Dir -> PackageDatabase
UserPkgDb (InstallLocation -> InstalledPackageLocation
InstalledTo InstallLocation
Local) Path Abs Dir
localDBPath) [LoadHelper]
installedLibs2
let installedLibs :: InstalledMap
installedLibs =
(LoadHelper -> InstalledMap -> InstalledMap)
-> InstalledMap -> [LoadHelper] -> InstalledMap
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' LoadHelper -> InstalledMap -> InstalledMap
gatherAndTransformSubLoadHelper InstalledMap
forall a. Monoid a => a
mempty [LoadHelper]
installedLibs3
let exesToSM :: InstallLocation -> [PackageIdentifier] -> InstalledMap
exesToSM InstallLocation
loc = [InstalledMap] -> InstalledMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([InstalledMap] -> InstalledMap)
-> ([PackageIdentifier] -> [InstalledMap])
-> [PackageIdentifier]
-> InstalledMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifier -> InstalledMap)
-> [PackageIdentifier] -> [InstalledMap]
forall a b. (a -> b) -> [a] -> [b]
map (InstallLocation -> PackageIdentifier -> InstalledMap
exeToSM InstallLocation
loc)
exeToSM :: InstallLocation -> PackageIdentifier -> InstalledMap
exeToSM InstallLocation
loc (PackageIdentifier PackageName
name Version
version) =
case PackageName -> InstallMap -> Maybe (InstallLocation, Version)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
Maybe (InstallLocation, Version)
Nothing -> InstalledMap
m
Just (InstallLocation
iLoc, Version
iVersion)
| Version
version Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
iVersion Bool -> Bool -> Bool
|| InstallLocation -> InstallLocation -> Bool
mismatchingLoc InstallLocation
loc InstallLocation
iLoc -> InstalledMap
forall k a. Map k a
Map.empty
| Bool
otherwise -> InstalledMap
m
where
m :: InstalledMap
m = PackageName -> (InstallLocation, Installed) -> InstalledMap
forall k a. k -> a -> Map k a
Map.singleton PackageName
name (InstallLocation
loc, PackageIdentifier -> Installed
Executable (PackageIdentifier -> Installed) -> PackageIdentifier -> Installed
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version)
mismatchingLoc :: InstallLocation -> InstallLocation -> Bool
mismatchingLoc InstallLocation
installed InstallLocation
target
| InstallLocation
target InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
installed = Bool
False
| InstallLocation
installed InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Local = Bool
False
| Bool
otherwise = Bool
True
[PackageIdentifier]
exesSnap <- InstallLocation -> RIO env [PackageIdentifier]
forall env.
HasEnvConfig env =>
InstallLocation -> RIO env [PackageIdentifier]
getInstalledExes InstallLocation
Snap
[PackageIdentifier]
exesLocal <- InstallLocation -> RIO env [PackageIdentifier]
forall env.
HasEnvConfig env =>
InstallLocation -> RIO env [PackageIdentifier]
getInstalledExes InstallLocation
Local
let installedMap :: InstalledMap
installedMap = [InstalledMap] -> InstalledMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
[ InstallLocation -> [PackageIdentifier] -> InstalledMap
exesToSM InstallLocation
Local [PackageIdentifier]
exesLocal
, InstallLocation -> [PackageIdentifier] -> InstalledMap
exesToSM InstallLocation
Snap [PackageIdentifier]
exesSnap
, InstalledMap
installedLibs
]
(InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( InstalledMap
installedMap
, [DumpPackage]
globalDumpPkgs
, [DumpPackage]
snapshotDumpPkgs
, [DumpPackage]
localDumpPkgs
)
loadDatabase ::
forall env. HasEnvConfig env
=> InstallMap
-> PackageDatabase
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase :: forall env.
HasEnvConfig env =>
InstallMap
-> PackageDatabase
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase InstallMap
installMap PackageDatabase
db [LoadHelper]
lhs0 = do
GhcPkgExe
pkgexe <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
([(Allowed, LoadHelper)]
lhs1', [DumpPackage]
dps) <- GhcPkgExe
-> [Path Abs Dir]
-> ConduitM
Text Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> RIO env ([(Allowed, LoadHelper)], [DumpPackage])
forall env a.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir] -> ConduitM Text Void (RIO env) a -> RIO env a
ghcPkgDump GhcPkgExe
pkgexe [Path Abs Dir]
pkgDb (ConduitM
Text Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> RIO env ([(Allowed, LoadHelper)], [DumpPackage]))
-> ConduitM
Text Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> RIO env ([(Allowed, LoadHelper)], [DumpPackage])
forall a b. (a -> b) -> a -> b
$ ConduitM Text DumpPackage (RIO env) ()
forall (m :: * -> *).
MonadThrow m =>
ConduitM Text DumpPackage m ()
conduitDumpPackage ConduitM Text DumpPackage (RIO env) ()
-> ConduitT
DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitM
Text Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
sink
[LoadHelper]
lhs1 <- ((Allowed, LoadHelper) -> RIO env (Maybe LoadHelper))
-> [(Allowed, LoadHelper)] -> RIO env [LoadHelper]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper)
processLoadResult [(Allowed, LoadHelper)]
lhs1'
let lhs :: Map GhcPkgId LoadHelper
lhs = (GhcPkgId -> GhcPkgId)
-> (LoadHelper -> GhcPkgId)
-> (LoadHelper -> [GhcPkgId])
-> (LoadHelper -> LoadHelper -> LoadHelper)
-> [LoadHelper]
-> Map GhcPkgId LoadHelper
forall name id item.
(Ord name, Ord id) =>
(id -> name)
-> (item -> id)
-> (item -> [id])
-> (item -> item -> item)
-> [item]
-> Map name item
pruneDeps GhcPkgId -> GhcPkgId
forall a. a -> a
id (.ghcPkgId) (.depsGhcPkgId) LoadHelper -> LoadHelper -> LoadHelper
forall a b. a -> b -> a
const ([LoadHelper]
lhs0 [LoadHelper] -> [LoadHelper] -> [LoadHelper]
forall a. [a] -> [a] -> [a]
++ [LoadHelper]
lhs1)
([LoadHelper], [DumpPackage])
-> RIO env ([LoadHelper], [DumpPackage])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LoadHelper -> LoadHelper) -> [LoadHelper] -> [LoadHelper]
forall a b. (a -> b) -> [a] -> [b]
map (\LoadHelper
lh -> LoadHelper
lh { depsGhcPkgId = [] }) ([LoadHelper] -> [LoadHelper]) -> [LoadHelper] -> [LoadHelper]
forall a b. (a -> b) -> a -> b
$ Map GhcPkgId LoadHelper -> [LoadHelper]
forall k a. Map k a -> [a]
Map.elems Map GhcPkgId LoadHelper
lhs, [DumpPackage]
dps)
where
pkgDb :: [Path Abs Dir]
pkgDb = case PackageDatabase
db of
PackageDatabase
GlobalPkgDb -> []
UserPkgDb InstalledPackageLocation
_ Path Abs Dir
fp -> [Path Abs Dir
fp]
sinkDP :: ConduitT DumpPackage c (RIO env) [(Allowed, LoadHelper)]
sinkDP = (DumpPackage -> (Allowed, LoadHelper))
-> ConduitT DumpPackage (Allowed, LoadHelper) (RIO env) ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map (InstallMap -> PackageDbVariety -> DumpPackage -> Allowed
isAllowed InstallMap
installMap PackageDbVariety
db' (DumpPackage -> Allowed)
-> (DumpPackage -> LoadHelper)
-> DumpPackage
-> (Allowed, LoadHelper)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& PackageDbVariety -> DumpPackage -> LoadHelper
toLoadHelper PackageDbVariety
db')
ConduitT DumpPackage (Allowed, LoadHelper) (RIO env) ()
-> ConduitT
(Allowed, LoadHelper) c (RIO env) [(Allowed, LoadHelper)]
-> ConduitT DumpPackage c (RIO env) [(Allowed, LoadHelper)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT (Allowed, LoadHelper) c (RIO env) [(Allowed, LoadHelper)]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
where
db' :: PackageDbVariety
db' = PackageDatabase -> PackageDbVariety
toPackageDbVariety PackageDatabase
db
sink :: ConduitT
DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
sink = ZipSink
DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitT
DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall i (m :: * -> *) r. ZipSink i m r -> ConduitT i Void m r
getZipSink (ZipSink
DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitT
DumpPackage
Void
(RIO env)
([(Allowed, LoadHelper)], [DumpPackage]))
-> ZipSink
DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitT
DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall a b. (a -> b) -> a -> b
$ (,)
([(Allowed, LoadHelper)]
-> [DumpPackage] -> ([(Allowed, LoadHelper)], [DumpPackage]))
-> ZipSink DumpPackage (RIO env) [(Allowed, LoadHelper)]
-> ZipSink
DumpPackage
(RIO env)
([DumpPackage] -> ([(Allowed, LoadHelper)], [DumpPackage]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT DumpPackage Void (RIO env) [(Allowed, LoadHelper)]
-> ZipSink DumpPackage (RIO env) [(Allowed, LoadHelper)]
forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink ConduitT DumpPackage Void (RIO env) [(Allowed, LoadHelper)]
forall {c}.
ConduitT DumpPackage c (RIO env) [(Allowed, LoadHelper)]
sinkDP
ZipSink
DumpPackage
(RIO env)
([DumpPackage] -> ([(Allowed, LoadHelper)], [DumpPackage]))
-> ZipSink DumpPackage (RIO env) [DumpPackage]
-> ZipSink
DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall a b.
ZipSink DumpPackage (RIO env) (a -> b)
-> ZipSink DumpPackage (RIO env) a
-> ZipSink DumpPackage (RIO env) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConduitT DumpPackage Void (RIO env) [DumpPackage]
-> ZipSink DumpPackage (RIO env) [DumpPackage]
forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink ConduitT DumpPackage Void (RIO env) [DumpPackage]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
processLoadResult :: (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper)
processLoadResult :: (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper)
processLoadResult (Allowed
Allowed, LoadHelper
lh) = Maybe LoadHelper -> RIO env (Maybe LoadHelper)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoadHelper -> Maybe LoadHelper
forall a. a -> Maybe a
Just LoadHelper
lh)
processLoadResult (Allowed
reason, LoadHelper
lh) = do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Ignoring package "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageName -> Utf8Builder
forall a. IsString a => PackageName -> a
fromPackageName ((PackageName, (InstallLocation, Installed)) -> PackageName
forall a b. (a, b) -> a
fst LoadHelper
lh.pair)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> case PackageDatabase
db of
PackageDatabase
GlobalPkgDb -> Utf8Builder
forall a. Monoid a => a
mempty
UserPkgDb InstalledPackageLocation
loc Path Abs Dir
fp -> Utf8Builder
", from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (InstalledPackageLocation, Path Abs Dir) -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (InstalledPackageLocation
loc, Path Abs Dir
fp) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
","
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" due to"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> case Allowed
reason of
Allowed
UnknownPkg -> Utf8Builder
" it being unknown to the resolver / extra-deps."
WrongLocation PackageDbVariety
db' InstallLocation
loc ->
Utf8Builder
" wrong location: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (PackageDbVariety, InstallLocation) -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (PackageDbVariety
db', InstallLocation
loc)
WrongVersion Version
actual Version
wanted ->
Utf8Builder
" wanting version "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
wanted)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" instead of "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
actual)
Maybe LoadHelper -> RIO env (Maybe LoadHelper)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LoadHelper
forall a. Maybe a
Nothing
data Allowed
= Allowed
| UnknownPkg
| WrongLocation PackageDbVariety InstallLocation
| WrongVersion Version Version
deriving (Allowed -> Allowed -> Bool
(Allowed -> Allowed -> Bool)
-> (Allowed -> Allowed -> Bool) -> Eq Allowed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Allowed -> Allowed -> Bool
== :: Allowed -> Allowed -> Bool
$c/= :: Allowed -> Allowed -> Bool
/= :: Allowed -> Allowed -> Bool
Eq, Int -> Allowed -> ShowS
[Allowed] -> ShowS
Allowed -> String
(Int -> Allowed -> ShowS)
-> (Allowed -> String) -> ([Allowed] -> ShowS) -> Show Allowed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Allowed -> ShowS
showsPrec :: Int -> Allowed -> ShowS
$cshow :: Allowed -> String
show :: Allowed -> String
$cshowList :: [Allowed] -> ShowS
showList :: [Allowed] -> ShowS
Show)
isAllowed ::
InstallMap
-> PackageDbVariety
-> DumpPackage
-> Allowed
isAllowed :: InstallMap -> PackageDbVariety -> DumpPackage -> Allowed
isAllowed InstallMap
installMap PackageDbVariety
pkgDb DumpPackage
dp = case PackageName -> InstallMap -> Maybe (InstallLocation, Version)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
Maybe (InstallLocation, Version)
Nothing ->
case DumpPackage -> Maybe PackageIdentifier
dpParentLibIdent DumpPackage
dp of
Just (PackageIdentifier PackageName
parentLibName Version
version') ->
case PackageName -> InstallMap -> Maybe (InstallLocation, Version)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
parentLibName InstallMap
installMap of
Maybe (InstallLocation, Version)
Nothing -> Allowed
checkNotFound
Just (InstallLocation, Version)
instInfo
| Version
version' Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
version -> (InstallLocation, Version) -> Allowed
checkFound (InstallLocation, Version)
instInfo
| Bool
otherwise -> Allowed
checkNotFound
Maybe PackageIdentifier
Nothing -> Allowed
checkNotFound
Just (InstallLocation, Version)
pii -> (InstallLocation, Version) -> Allowed
checkFound (InstallLocation, Version)
pii
where
PackageIdentifier PackageName
name Version
version = DumpPackage
dp.packageIdent
checkLocation :: InstallLocation -> Bool
checkLocation InstallLocation
Snap =
Bool
True
checkLocation InstallLocation
Local = case PackageDbVariety
pkgDb of
PackageDbVariety
GlobalDb -> Bool
False
PackageDbVariety
ExtraDb -> Bool
True
PackageDbVariety
WriteOnlyDb -> Bool
False
PackageDbVariety
MutableDb -> Bool
True
checkFound :: (InstallLocation, Version) -> Allowed
checkFound (InstallLocation
installLoc, Version
installVer)
| Bool -> Bool
not (InstallLocation -> Bool
checkLocation InstallLocation
installLoc) = PackageDbVariety -> InstallLocation -> Allowed
WrongLocation PackageDbVariety
pkgDb InstallLocation
installLoc
| Version
version Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
installVer = Version -> Version -> Allowed
WrongVersion Version
version Version
installVer
| Bool
otherwise = Allowed
Allowed
checkNotFound :: Allowed
checkNotFound = case PackageDbVariety
pkgDb of
PackageDbVariety
GlobalDb -> Allowed
Allowed
PackageDbVariety
ExtraDb -> Allowed
Allowed
PackageDbVariety
WriteOnlyDb -> Allowed
UnknownPkg
PackageDbVariety
MutableDb -> Allowed
UnknownPkg
data LoadHelper = LoadHelper
{ LoadHelper -> GhcPkgId
ghcPkgId :: !GhcPkgId
, LoadHelper -> Maybe SublibDump
subLibDump :: !(Maybe SublibDump)
, LoadHelper -> [GhcPkgId]
depsGhcPkgId :: ![GhcPkgId]
, LoadHelper -> (PackageName, (InstallLocation, Installed))
pair :: !(PackageName, (InstallLocation, Installed))
}
deriving Int -> LoadHelper -> ShowS
[LoadHelper] -> ShowS
LoadHelper -> String
(Int -> LoadHelper -> ShowS)
-> (LoadHelper -> String)
-> ([LoadHelper] -> ShowS)
-> Show LoadHelper
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoadHelper -> ShowS
showsPrec :: Int -> LoadHelper -> ShowS
$cshow :: LoadHelper -> String
show :: LoadHelper -> String
$cshowList :: [LoadHelper] -> ShowS
showList :: [LoadHelper] -> ShowS
Show
toLoadHelper :: PackageDbVariety -> DumpPackage -> LoadHelper
toLoadHelper :: PackageDbVariety -> DumpPackage -> LoadHelper
toLoadHelper PackageDbVariety
pkgDb DumpPackage
dp = LoadHelper
{ GhcPkgId
$sel:ghcPkgId:LoadHelper :: GhcPkgId
ghcPkgId :: GhcPkgId
ghcPkgId
, [GhcPkgId]
$sel:depsGhcPkgId:LoadHelper :: [GhcPkgId]
depsGhcPkgId :: [GhcPkgId]
depsGhcPkgId
, $sel:subLibDump:LoadHelper :: Maybe SublibDump
subLibDump = DumpPackage
dp.sublib
, (PackageName, (InstallLocation, Installed))
$sel:pair:LoadHelper :: (PackageName, (InstallLocation, Installed))
pair :: (PackageName, (InstallLocation, Installed))
pair
}
where
ghcPkgId :: GhcPkgId
ghcPkgId = DumpPackage
dp.ghcPkgId
ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
_) = DumpPackage
dp.packageIdent
depsGhcPkgId :: [GhcPkgId]
depsGhcPkgId =
if PackageName
name PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages
then []
else DumpPackage
dp.depends
installedLibInfo :: InstalledLibraryInfo
installedLibInfo = GhcPkgId
-> Maybe (Either License License)
-> Map StackUnqualCompName GhcPkgId
-> InstalledLibraryInfo
InstalledLibraryInfo GhcPkgId
ghcPkgId (License -> Either License License
forall a b. b -> Either a b
Right (License -> Either License License)
-> Maybe License -> Maybe (Either License License)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DumpPackage
dp.license) Map StackUnqualCompName GhcPkgId
forall a. Monoid a => a
mempty
toInstallLocation :: PackageDbVariety -> InstallLocation
toInstallLocation :: PackageDbVariety -> InstallLocation
toInstallLocation PackageDbVariety
GlobalDb = InstallLocation
Snap
toInstallLocation PackageDbVariety
ExtraDb = InstallLocation
Snap
toInstallLocation PackageDbVariety
WriteOnlyDb = InstallLocation
Snap
toInstallLocation PackageDbVariety
MutableDb = InstallLocation
Local
pair :: (PackageName, (InstallLocation, Installed))
pair = (PackageName
name, (PackageDbVariety -> InstallLocation
toInstallLocation PackageDbVariety
pkgDb, PackageIdentifier -> InstalledLibraryInfo -> Installed
Library PackageIdentifier
ident InstalledLibraryInfo
installedLibInfo))
gatherAndTransformSubLoadHelper ::
LoadHelper
-> Map PackageName (InstallLocation, Installed)
-> Map PackageName (InstallLocation, Installed)
gatherAndTransformSubLoadHelper :: LoadHelper -> InstalledMap -> InstalledMap
gatherAndTransformSubLoadHelper LoadHelper
lh =
((InstallLocation, Installed)
-> (InstallLocation, Installed) -> (InstallLocation, Installed))
-> PackageName
-> (InstallLocation, Installed)
-> InstalledMap
-> InstalledMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (InstallLocation, Installed)
-> (InstallLocation, Installed) -> (InstallLocation, Installed)
forall {a} {a}. (a, Installed) -> (a, Installed) -> (a, Installed)
onPreviousLoadHelper PackageName
key (InstallLocation, Installed)
value
where
onPreviousLoadHelper :: (a, Installed) -> (a, Installed) -> (a, Installed)
onPreviousLoadHelper
(a
pLoc, Library PackageIdentifier
pn InstalledLibraryInfo
incomingLibInfo)
(a
_, Library PackageIdentifier
_ InstalledLibraryInfo
existingLibInfo)
= ( a
pLoc
, PackageIdentifier -> InstalledLibraryInfo -> Installed
Library PackageIdentifier
pn InstalledLibraryInfo
existingLibInfo
{ subLib = Map.union
incomingLibInfo.subLib
existingLibInfo.subLib
, ghcPkgId = if isJust lh.subLibDump
then existingLibInfo.ghcPkgId
else incomingLibInfo.ghcPkgId
}
)
onPreviousLoadHelper (a, Installed)
newVal (a, Installed)
_oldVal = (a, Installed)
newVal
(PackageName
key, (InstallLocation, Installed)
value) = case LoadHelper
lh.subLibDump of
Maybe SublibDump
Nothing -> (PackageName
rawPackageName, (InstallLocation, Installed)
rawValue)
Just SublibDump
sd -> (SublibDump
sd.packageName, SublibDump -> Installed -> Installed
updateAsSublib SublibDump
sd (Installed -> Installed)
-> (InstallLocation, Installed) -> (InstallLocation, Installed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (InstallLocation, Installed)
rawValue)
(PackageName
rawPackageName, (InstallLocation, Installed)
rawValue) = LoadHelper
lh.pair
updateAsSublib :: SublibDump -> Installed -> Installed
updateAsSublib
SublibDump
sd
(Library (PackageIdentifier PackageName
_sublibMungedPackageName Version
version) InstalledLibraryInfo
libInfo)
= PackageIdentifier -> InstalledLibraryInfo -> Installed
Library
(PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
key Version
version)
InstalledLibraryInfo
libInfo { subLib = Map.singleton sd.libraryName libInfo.ghcPkgId }
updateAsSublib SublibDump
_ Installed
v = Installed
v