module Distribution.Client.Fetch (
fetch,
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Client.Types
import Distribution.Client.Targets
import Distribution.Client.FetchUtils hiding (fetchPackage)
import Distribution.Client.Dependency
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.Setup
( GlobalFlags(..), FetchFlags(..), RepoContext(..) )
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb )
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.SourcePackage
import Distribution.Package
( packageId )
import Distribution.Simple.Compiler
( Compiler, compilerInfo, PackageDBStack )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.Program
( ProgramDb )
import Distribution.Simple.Setup
( fromFlag, fromFlagOrDefault )
import Distribution.Simple.Utils
( die', notice, debug )
import Distribution.System
( Platform )
fetch :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FetchFlags
-> [UserTarget]
-> IO ()
fetch :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FetchFlags
-> [UserTarget]
-> IO ()
fetch Verbosity
verbosity PackageDBStack
_ RepoContext
_ Compiler
_ Platform
_ ProgramDb
_ GlobalFlags
_ FetchFlags
_ [] =
Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"No packages requested. Nothing to do."
fetch Verbosity
verbosity PackageDBStack
packageDBs RepoContext
repoCtxt Compiler
comp Platform
platform ProgramDb
progdb
GlobalFlags
_ FetchFlags
fetchFlags [UserTarget]
userTargets = do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> UserTarget -> IO ()
checkTarget Verbosity
verbosity) [UserTarget]
userTargets
InstalledPackageIndex
installedPkgIndex <- Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp PackageDBStack
packageDBs ProgramDb
progdb
SourcePackageDb
sourcePkgDb <- Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages Verbosity
verbosity RepoContext
repoCtxt
PkgConfigDb
pkgConfigDb <- Verbosity -> ProgramDb -> IO PkgConfigDb
readPkgConfigDb Verbosity
verbosity ProgramDb
progdb
[PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers <- forall pkg.
Package pkg =>
Verbosity
-> RepoContext
-> PackageIndex pkg
-> [UserTarget]
-> IO [PackageSpecifier UnresolvedSourcePackage]
resolveUserTargets Verbosity
verbosity RepoContext
repoCtxt
(SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
sourcePkgDb)
[UserTarget]
userTargets
[UnresolvedSourcePackage]
pkgs <- Verbosity
-> Compiler
-> Platform
-> FetchFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO [UnresolvedSourcePackage]
planPackages
Verbosity
verbosity Compiler
comp Platform
platform FetchFlags
fetchFlags
InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb PkgConfigDb
pkgConfigDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
[UnresolvedSourcePackage]
pkgs' <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedPkgLoc -> IO Bool
isFetched forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. SourcePackage loc -> loc
srcpkgSource) [UnresolvedSourcePackage]
pkgs
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnresolvedSourcePackage]
pkgs'
then Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"No packages need to be fetched. "
forall a. [a] -> [a] -> [a]
++ String
"All the requested packages are already local "
forall a. [a] -> [a] -> [a]
++ String
"or cached locally."
else if Bool
dryRun
then Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
String
"The following packages would be fetched:"
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> String
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageIdentifier
packageId) [UnresolvedSourcePackage]
pkgs'
else forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall a. Verbosity -> RepoContext -> PackageLocation a -> IO ()
fetchPackage Verbosity
verbosity RepoContext
repoCtxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. SourcePackage loc -> loc
srcpkgSource) [UnresolvedSourcePackage]
pkgs'
where
dryRun :: Bool
dryRun = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag Bool
fetchDryRun FetchFlags
fetchFlags)
planPackages :: Verbosity
-> Compiler
-> Platform
-> FetchFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO [UnresolvedSourcePackage]
planPackages :: Verbosity
-> Compiler
-> Platform
-> FetchFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO [UnresolvedSourcePackage]
planPackages Verbosity
verbosity Compiler
comp Platform
platform FetchFlags
fetchFlags
InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb PkgConfigDb
pkgConfigDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
| Bool
includeDependencies = do
Solver
solver <- Verbosity -> PreSolver -> CompilerInfo -> IO Solver
chooseSolver Verbosity
verbosity
(forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag PreSolver
fetchSolver FetchFlags
fetchFlags)) (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"Resolving dependencies..."
SolverInstallPlan
installPlan <- forall step a fail done.
(step -> a -> a)
-> (fail -> a) -> (done -> a) -> Progress step fail done -> a
foldProgress forall {b}. String -> IO b -> IO b
logMsg (forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
Platform
-> CompilerInfo
-> PkgConfigDb
-> Solver
-> DepResolverParams
-> Progress String String SolverInstallPlan
resolveDependencies
Platform
platform (Compiler -> CompilerInfo
compilerInfo Compiler
comp) PkgConfigDb
pkgConfigDb
Solver
solver
DepResolverParams
resolverParams
forall (m :: * -> *) a. Monad m => a -> m a
return
[ forall loc. SolverPackage loc -> SourcePackage loc
solverPkgSource SolverPackage UnresolvedPkgLoc
cpkg
| (SolverInstallPlan.Configured SolverPackage UnresolvedPkgLoc
cpkg)
<- SolverInstallPlan -> [ResolverPackage UnresolvedPkgLoc]
SolverInstallPlan.toList SolverInstallPlan
installPlan ]
| Bool
otherwise =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
DepResolverParams
-> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
resolveWithoutDependencies DepResolverParams
resolverParams
where
resolverParams :: DepResolverParams
resolverParams :: DepResolverParams
resolverParams =
Maybe Int -> DepResolverParams -> DepResolverParams
setMaxBackjumps (if Int
maxBackjumps forall a. Ord a => a -> a -> Bool
< Int
0 then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just Int
maxBackjumps)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndependentGoals -> DepResolverParams -> DepResolverParams
setIndependentGoals IndependentGoals
independentGoals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReorderGoals -> DepResolverParams -> DepResolverParams
setReorderGoals ReorderGoals
reorderGoals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CountConflicts -> DepResolverParams -> DepResolverParams
setCountConflicts CountConflicts
countConflicts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FineGrainedConflicts -> DepResolverParams -> DepResolverParams
setFineGrainedConflicts FineGrainedConflicts
fineGrainedConflicts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MinimizeConflictSet -> DepResolverParams -> DepResolverParams
setMinimizeConflictSet MinimizeConflictSet
minimizeConflictSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShadowPkgs -> DepResolverParams -> DepResolverParams
setShadowPkgs ShadowPkgs
shadowPkgs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrongFlags -> DepResolverParams -> DepResolverParams
setStrongFlags StrongFlags
strongFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllowBootLibInstalls -> DepResolverParams -> DepResolverParams
setAllowBootLibInstalls AllowBootLibInstalls
allowBootLibInstalls
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnlyConstrained -> DepResolverParams -> DepResolverParams
setOnlyConstrained OnlyConstrained
onlyConstrained
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> DepResolverParams -> DepResolverParams
setSolverVerbosity Verbosity
verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabeledPackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints
[ let pc :: PackageConstraint
pc = ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint
(PackageName -> ConstraintScope
scopeToplevel forall a b. (a -> b) -> a -> b
$ forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget PackageSpecifier UnresolvedSourcePackage
pkgSpecifier)
([OptionalStanza] -> PackageProperty
PackagePropertyStanzas [OptionalStanza]
stanzas)
in PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint PackageConstraint
pc ConstraintSource
ConstraintSourceConfigFlagOrTarget
| PackageSpecifier UnresolvedSourcePackage
pkgSpecifier <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepResolverParams -> DepResolverParams
reinstallTargets
forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
standardInstallPolicy InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
includeDependencies :: Bool
includeDependencies = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag Bool
fetchDeps FetchFlags
fetchFlags)
logMsg :: String -> IO b -> IO b
logMsg String
message IO b
rest = Verbosity -> String -> IO ()
debug Verbosity
verbosity String
message forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO b
rest
stanzas :: [OptionalStanza]
stanzas = [ OptionalStanza
TestStanzas | Bool
testsEnabled ]
forall a. [a] -> [a] -> [a]
++ [ OptionalStanza
BenchStanzas | Bool
benchmarksEnabled ]
testsEnabled :: Bool
testsEnabled = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall a b. (a -> b) -> a -> b
$ FetchFlags -> Flag Bool
fetchTests FetchFlags
fetchFlags
benchmarksEnabled :: Bool
benchmarksEnabled = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall a b. (a -> b) -> a -> b
$ FetchFlags -> Flag Bool
fetchBenchmarks FetchFlags
fetchFlags
reorderGoals :: ReorderGoals
reorderGoals = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag ReorderGoals
fetchReorderGoals FetchFlags
fetchFlags)
countConflicts :: CountConflicts
countConflicts = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag CountConflicts
fetchCountConflicts FetchFlags
fetchFlags)
fineGrainedConflicts :: FineGrainedConflicts
fineGrainedConflicts = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag FineGrainedConflicts
fetchFineGrainedConflicts FetchFlags
fetchFlags)
minimizeConflictSet :: MinimizeConflictSet
minimizeConflictSet = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag MinimizeConflictSet
fetchMinimizeConflictSet FetchFlags
fetchFlags)
independentGoals :: IndependentGoals
independentGoals = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag IndependentGoals
fetchIndependentGoals FetchFlags
fetchFlags)
shadowPkgs :: ShadowPkgs
shadowPkgs = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag ShadowPkgs
fetchShadowPkgs FetchFlags
fetchFlags)
strongFlags :: StrongFlags
strongFlags = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag StrongFlags
fetchStrongFlags FetchFlags
fetchFlags)
maxBackjumps :: Int
maxBackjumps = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag Int
fetchMaxBackjumps FetchFlags
fetchFlags)
allowBootLibInstalls :: AllowBootLibInstalls
allowBootLibInstalls = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag AllowBootLibInstalls
fetchAllowBootLibInstalls FetchFlags
fetchFlags)
onlyConstrained :: OnlyConstrained
onlyConstrained = forall a. WithCallStack (Flag a -> a)
fromFlag (FetchFlags -> Flag OnlyConstrained
fetchOnlyConstrained FetchFlags
fetchFlags)
checkTarget :: Verbosity -> UserTarget -> IO ()
checkTarget :: Verbosity -> UserTarget -> IO ()
checkTarget Verbosity
verbosity UserTarget
target = case UserTarget
target of
UserTargetRemoteTarball URI
_uri
-> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"The 'fetch' command does not yet support remote tarballs. "
forall a. [a] -> [a] -> [a]
++ String
"In the meantime you can use the 'unpack' commands."
UserTarget
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO ()
fetchPackage :: forall a. Verbosity -> RepoContext -> PackageLocation a -> IO ()
fetchPackage Verbosity
verbosity RepoContext
repoCtxt PackageLocation a
pkgsrc = case PackageLocation a
pkgsrc of
LocalUnpackedPackage String
_dir -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
LocalTarballPackage String
_file -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
RemoteTarballPackage URI
_uri a
_ ->
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"The 'fetch' command does not yet support remote tarballs. "
forall a. [a] -> [a] -> [a]
++ String
"In the meantime you can use the 'unpack' commands."
RemoteSourceRepoPackage SourceRepoMaybe
_repo a
_ ->
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"The 'fetch' command does not yet support remote "
forall a. [a] -> [a] -> [a]
++ String
"source repositories."
RepoTarballPackage Repo
repo PackageIdentifier
pkgid a
_ -> do
String
_ <- Verbosity -> RepoContext -> Repo -> PackageIdentifier -> IO String
fetchRepoTarball Verbosity
verbosity RepoContext
repoCtxt Repo
repo PackageIdentifier
pkgid
forall (m :: * -> *) a. Monad m => a -> m a
return ()