{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Build.Installed
( InstalledMap
, Installed (..)
, getInstalled
, InstallMap
, toInstallMap
) where
import Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.Set as Set
import Data.List
import qualified Data.Map.Strict as Map
import Path
import Stack.Build.Cache
import Stack.Constants
import Stack.PackageDump
import Stack.Prelude
import Stack.SourceMap (getPLIVersion, loadVersion)
import Stack.Types.Build
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.Package
import Stack.Types.SourceMap
toInstallMap :: MonadIO m => SourceMap -> m InstallMap
toInstallMap :: 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 -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap) ((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 -> CommonPackage
ppCommon ProjectPackage
pp)
(InstallLocation, Version) -> m (InstallLocation, Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 -> Map PackageName DepPackage
smDeps SourceMap
sourceMap) ((DepPackage -> m (InstallLocation, Version)) -> m InstallMap)
-> (DepPackage -> m (InstallLocation, Version)) -> m InstallMap
forall a b. (a -> b) -> a -> b
$ \DepPackage
dp ->
case DepPackage -> PackageLocation
dpLocation DepPackage
dp of
PLImmutable PackageLocationImmutable
pli -> (InstallLocation, Version) -> m (InstallLocation, Version)
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 -> CommonPackage
dpCommon DepPackage
dp)
(InstallLocation, Version) -> m (InstallLocation, Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstallLocation
Local, Version
version)
InstallMap -> m InstallMap
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: 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 :: * -> *).
(MonadReader env m, HasEnvConfig env) =>
m [Path Abs Dir]
packageDatabaseExtra
let loadDatabase' :: Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' = InstallMap
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase InstallMap
installMap
([LoadHelper]
installedLibs0, [DumpPackage]
globalDumpPkgs) <- Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' Maybe (InstalledPackageLocation, Path Abs Dir)
forall a. Maybe a
Nothing []
([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 ->
Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' ((InstalledPackageLocation, Path Abs Dir)
-> Maybe (InstalledPackageLocation, Path Abs Dir)
forall a. a -> Maybe a
Just (InstalledPackageLocation
ExtraGlobal, 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) <-
Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' ((InstalledPackageLocation, Path Abs Dir)
-> Maybe (InstalledPackageLocation, Path Abs Dir)
forall a. a -> Maybe a
Just (InstallLocation -> InstalledPackageLocation
InstalledTo InstallLocation
Snap, Path Abs Dir
snapDBPath)) [LoadHelper]
installedLibs1
([LoadHelper]
installedLibs3, [DumpPackage]
localDumpPkgs) <-
Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' ((InstalledPackageLocation, Path Abs Dir)
-> Maybe (InstalledPackageLocation, Path Abs Dir)
forall a. a -> Maybe a
Just (InstallLocation -> InstalledPackageLocation
InstalledTo InstallLocation
Local, Path Abs Dir
localDBPath)) [LoadHelper]
installedLibs2
let installedLibs :: InstalledMap
installedLibs = [(PackageName, (InstallLocation, Installed))] -> InstalledMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, (InstallLocation, Installed))] -> InstalledMap)
-> [(PackageName, (InstallLocation, Installed))] -> InstalledMap
forall a b. (a -> b) -> a -> b
$ (LoadHelper -> (PackageName, (InstallLocation, Installed)))
-> [LoadHelper] -> [(PackageName, (InstallLocation, Installed))]
forall a b. (a -> b) -> [a] -> [b]
map LoadHelper -> (PackageName, (InstallLocation, Installed))
lhPair [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 (m :: * -> *) a. Monad m => a -> m a
return ( InstalledMap
installedMap
, [DumpPackage]
globalDumpPkgs
, [DumpPackage]
snapshotDumpPkgs
, [DumpPackage]
localDumpPkgs
)
loadDatabase :: HasEnvConfig env
=> InstallMap
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase :: InstallMap
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase InstallMap
installMap Maybe (InstalledPackageLocation, Path Abs Dir)
mdb [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, HasLogFunc env) =>
GhcPkgExe
-> [Path Abs Dir] -> ConduitM Text Void (RIO env) a -> RIO env a
ghcPkgDump GhcPkgExe
pkgexe (((InstalledPackageLocation, Path Abs Dir) -> Path Abs Dir)
-> [(InstalledPackageLocation, Path Abs Dir)] -> [Path Abs Dir]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InstalledPackageLocation, Path Abs Dir) -> Path Abs Dir
forall a b. (a, b) -> b
snd (Maybe (InstalledPackageLocation, Path Abs Dir)
-> [(InstalledPackageLocation, Path Abs Dir)]
forall a. Maybe a -> [a]
maybeToList Maybe (InstalledPackageLocation, Path Abs Dir)
mdb))
(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) ()
-> ConduitM
DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitM
Text Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM
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 (Maybe (InstalledPackageLocation, Path Abs Dir)
-> (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper)
forall env.
HasLogFunc env =>
Maybe (InstalledPackageLocation, Path Abs Dir)
-> (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper)
processLoadResult Maybe (InstalledPackageLocation, Path Abs Dir)
mdb) [(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
LoadHelper -> GhcPkgId
lhId
LoadHelper -> [GhcPkgId]
lhDeps
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 (m :: * -> *) a. Monad m => a -> m a
return ((LoadHelper -> LoadHelper) -> [LoadHelper] -> [LoadHelper]
forall a b. (a -> b) -> [a] -> [b]
map (\LoadHelper
lh -> LoadHelper
lh { lhDeps :: [GhcPkgId]
lhDeps = [] }) ([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
mloc :: Maybe InstalledPackageLocation
mloc = ((InstalledPackageLocation, Path Abs Dir)
-> InstalledPackageLocation)
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> Maybe InstalledPackageLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InstalledPackageLocation, Path Abs Dir)
-> InstalledPackageLocation
forall a b. (a, b) -> a
fst Maybe (InstalledPackageLocation, Path Abs Dir)
mdb
sinkDP :: ConduitM 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
-> Maybe InstalledPackageLocation -> DumpPackage -> Allowed
isAllowed InstallMap
installMap Maybe InstalledPackageLocation
mloc (DumpPackage -> Allowed)
-> (DumpPackage -> LoadHelper)
-> DumpPackage
-> (Allowed, LoadHelper)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Maybe InstalledPackageLocation -> DumpPackage -> LoadHelper
toLoadHelper Maybe InstalledPackageLocation
mloc)
ConduitT DumpPackage (Allowed, LoadHelper) (RIO env) ()
-> ConduitM
(Allowed, LoadHelper) c (RIO env) [(Allowed, LoadHelper)]
-> ConduitM DumpPackage c (RIO env) [(Allowed, LoadHelper)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM (Allowed, LoadHelper) c (RIO env) [(Allowed, LoadHelper)]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
sink :: ConduitM
DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
sink = ZipSink
DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitM
DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall i (m :: * -> *) r. ZipSink i m r -> Sink i m r
getZipSink (ZipSink
DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitM
DumpPackage
Void
(RIO env)
([(Allowed, LoadHelper)], [DumpPackage]))
-> ZipSink
DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitM
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
<$> Sink DumpPackage (RIO env) [(Allowed, LoadHelper)]
-> ZipSink DumpPackage (RIO env) [(Allowed, LoadHelper)]
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink Sink DumpPackage (RIO env) [(Allowed, LoadHelper)]
forall c. ConduitM 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Sink DumpPackage (RIO env) [DumpPackage]
-> ZipSink DumpPackage (RIO env) [DumpPackage]
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink Sink DumpPackage (RIO env) [DumpPackage]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
processLoadResult :: HasLogFunc env
=> Maybe (InstalledPackageLocation, Path Abs Dir)
-> (Allowed, LoadHelper)
-> RIO env (Maybe LoadHelper)
processLoadResult :: Maybe (InstalledPackageLocation, Path Abs Dir)
-> (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper)
processLoadResult Maybe (InstalledPackageLocation, Path Abs Dir)
_ (Allowed
Allowed, LoadHelper
lh) = Maybe LoadHelper -> RIO env (Maybe LoadHelper)
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadHelper -> Maybe LoadHelper
forall a. a -> Maybe a
Just LoadHelper
lh)
processLoadResult Maybe (InstalledPackageLocation, Path Abs Dir)
mdb (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
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString ((PackageName, (InstallLocation, Installed)) -> PackageName
forall a b. (a, b) -> a
fst (LoadHelper -> (PackageName, (InstallLocation, Installed))
lhPair LoadHelper
lh))) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
-> ((InstalledPackageLocation, Path Abs Dir) -> Utf8Builder)
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> Utf8Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Utf8Builder
forall a. Monoid a => a
mempty (\(InstalledPackageLocation, Path Abs Dir)
db -> 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, Path Abs Dir)
db Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
",") Maybe (InstalledPackageLocation, Path Abs Dir)
mdb 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
Allowed -> Utf8Builder
" the impossible?!?!"
Allowed
UnknownPkg -> Utf8Builder
" it being unknown to the resolver / extra-deps."
WrongLocation Maybe InstalledPackageLocation
mloc InstallLocation
loc -> Utf8Builder
" wrong location: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (Maybe InstalledPackageLocation, InstallLocation) -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (Maybe InstalledPackageLocation
mloc, 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 (m :: * -> *) a. Monad m => a -> m a
return Maybe LoadHelper
forall a. Maybe a
Nothing
data Allowed
= Allowed
| UnknownPkg
| WrongLocation (Maybe InstalledPackageLocation) 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
/= :: Allowed -> Allowed -> Bool
$c/= :: Allowed -> Allowed -> Bool
== :: Allowed -> Allowed -> Bool
$c== :: 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
showList :: [Allowed] -> ShowS
$cshowList :: [Allowed] -> ShowS
show :: Allowed -> String
$cshow :: Allowed -> String
showsPrec :: Int -> Allowed -> ShowS
$cshowsPrec :: Int -> Allowed -> ShowS
Show)
isAllowed :: InstallMap
-> Maybe InstalledPackageLocation
-> DumpPackage
-> Allowed
isAllowed :: InstallMap
-> Maybe InstalledPackageLocation -> DumpPackage -> Allowed
isAllowed InstallMap
installMap Maybe InstalledPackageLocation
mloc 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 -> PackageIdentifier
dpPackageIdent DumpPackage
dp
checkLocation :: InstallLocation -> Bool
checkLocation InstallLocation
Snap = Bool
True
checkLocation InstallLocation
Local = Maybe InstalledPackageLocation
mloc Maybe InstalledPackageLocation
-> Maybe InstalledPackageLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstalledPackageLocation -> Maybe InstalledPackageLocation
forall a. a -> Maybe a
Just (InstallLocation -> InstalledPackageLocation
InstalledTo InstallLocation
Local) Bool -> Bool -> Bool
|| Maybe InstalledPackageLocation
mloc Maybe InstalledPackageLocation
-> Maybe InstalledPackageLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstalledPackageLocation -> Maybe InstalledPackageLocation
forall a. a -> Maybe a
Just InstalledPackageLocation
ExtraGlobal
checkFound :: (InstallLocation, Version) -> Allowed
checkFound (InstallLocation
installLoc, Version
installVer)
| Bool -> Bool
not (InstallLocation -> Bool
checkLocation InstallLocation
installLoc) = Maybe InstalledPackageLocation -> InstallLocation -> Allowed
WrongLocation Maybe InstalledPackageLocation
mloc 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 Maybe InstalledPackageLocation
mloc of
Maybe InstalledPackageLocation
Nothing -> Allowed
Allowed
Just InstalledPackageLocation
ExtraGlobal -> Allowed
Allowed
Just InstalledPackageLocation
_ -> Allowed
UnknownPkg
data LoadHelper = LoadHelper
{ LoadHelper -> GhcPkgId
lhId :: !GhcPkgId
, LoadHelper -> [GhcPkgId]
lhDeps :: ![GhcPkgId]
, LoadHelper -> (PackageName, (InstallLocation, Installed))
lhPair :: !(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
showList :: [LoadHelper] -> ShowS
$cshowList :: [LoadHelper] -> ShowS
show :: LoadHelper -> String
$cshow :: LoadHelper -> String
showsPrec :: Int -> LoadHelper -> ShowS
$cshowsPrec :: Int -> LoadHelper -> ShowS
Show
toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage -> LoadHelper
toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage -> LoadHelper
toLoadHelper Maybe InstalledPackageLocation
mloc DumpPackage
dp = LoadHelper :: GhcPkgId
-> [GhcPkgId]
-> (PackageName, (InstallLocation, Installed))
-> LoadHelper
LoadHelper
{ lhId :: GhcPkgId
lhId = GhcPkgId
gid
, lhDeps :: [GhcPkgId]
lhDeps =
if PackageName
name PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages
then []
else DumpPackage -> [GhcPkgId]
dpDepends DumpPackage
dp
, lhPair :: (PackageName, (InstallLocation, Installed))
lhPair = (PackageName
name, (Maybe InstalledPackageLocation -> InstallLocation
toPackageLocation Maybe InstalledPackageLocation
mloc, PackageIdentifier
-> GhcPkgId -> Maybe (Either License License) -> Installed
Library PackageIdentifier
ident GhcPkgId
gid (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 -> Maybe License
dpLicense DumpPackage
dp)))
}
where
gid :: GhcPkgId
gid = DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp
ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
_) = DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp
toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation
toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation
toPackageLocation Maybe InstalledPackageLocation
Nothing = InstallLocation
Snap
toPackageLocation (Just InstalledPackageLocation
ExtraGlobal) = InstallLocation
Snap
toPackageLocation (Just (InstalledTo InstallLocation
loc)) = InstallLocation
loc