{-# 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
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
$ \pp :: 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
$ \dp :: DepPackage
dp ->
case DepPackage -> PackageLocation
dpLocation DepPackage
dp of
PLImmutable pli :: PackageLocationImmutable
pli -> (InstallLocation, Version) -> m (InstallLocation, Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallLocation
Snap, PackageLocationImmutable -> Version
getPLIVersion PackageLocationImmutable
pli)
PLMutable _ -> 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
installMap = do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug "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
(installedLibs0 :: [LoadHelper]
installedLibs0, globalDumpPkgs :: [DumpPackage]
globalDumpPkgs) <- Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' Maybe (InstalledPackageLocation, Path Abs Dir)
forall a. Maybe a
Nothing []
(installedLibs1 :: [LoadHelper]
installedLibs1, _extraInstalled :: [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 (\lhs' :: ([LoadHelper], [DumpPackage])
lhs' pkgdb :: 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
(installedLibs2 :: [LoadHelper]
installedLibs2, snapshotDumpPkgs :: [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
(installedLibs3 :: [LoadHelper]
installedLibs3, localDumpPkgs :: [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 loc :: 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 loc :: InstallLocation
loc (PackageIdentifier name :: PackageName
name version :: 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
Nothing -> InstalledMap
m
Just (iLoc :: InstallLocation
iLoc, iVersion :: 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 installed :: InstallLocation
installed target :: 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
installMap mdb :: Maybe (InstalledPackageLocation, Path Abs Dir)
mdb lhs0 :: [LoadHelper]
lhs0 = do
GhcPkgExe
pkgexe <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
(lhs1' :: [(Allowed, LoadHelper)]
lhs1', dps :: [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 (\lh :: 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 _ (Allowed, lh :: 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 mdb :: Maybe (InstalledPackageLocation, Path Abs Dir)
mdb (reason :: Allowed
reason, lh :: 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
$
"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 (\db :: (InstalledPackageLocation, Path Abs Dir)
db -> ", 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
<> ",") Maybe (InstalledPackageLocation, Path Abs Dir)
mdb Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
" due to" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
case Allowed
reason of
Allowed -> " the impossible?!?!"
UnknownPkg -> " it being unknown to the resolver / extra-deps."
WrongLocation mloc :: Maybe InstalledPackageLocation
mloc loc :: InstallLocation
loc -> " 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 actual :: Version
actual wanted :: Version
wanted ->
" 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
<>
" 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
installMap mloc :: Maybe InstalledPackageLocation
mloc dp :: 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
Nothing ->
case DumpPackage -> Maybe PackageIdentifier
dpParentLibIdent DumpPackage
dp of
Just (PackageIdentifier parentLibName :: PackageName
parentLibName version' :: 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
Nothing -> Allowed
checkNotFound
Just instInfo :: (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
Nothing -> Allowed
checkNotFound
Just pii :: (InstallLocation, Version)
pii -> (InstallLocation, Version) -> Allowed
checkFound (InstallLocation, Version)
pii
where
PackageIdentifier name :: PackageName
name version :: Version
version = DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp
checkLocation :: InstallLocation -> Bool
checkLocation Snap = Bool
True
checkLocation 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 (installLoc :: InstallLocation
installLoc, installVer :: 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
Nothing -> Allowed
Allowed
Just ExtraGlobal -> Allowed
Allowed
Just _ -> 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 mloc :: Maybe InstalledPackageLocation
mloc dp :: DumpPackage
dp = $WLoadHelper :: 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 name :: PackageName
name _) = DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp
toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation
toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation
toPackageLocation Nothing = InstallLocation
Snap
toPackageLocation (Just ExtraGlobal) = InstallLocation
Snap
toPackageLocation (Just (InstalledTo loc :: InstallLocation
loc)) = InstallLocation
loc