module Distribution.Client.Freeze (
freeze, getFreezePkgs
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Client.Config ( SavedConfig(..) )
import Distribution.Client.Types
import Distribution.Client.Targets
import Distribution.Client.Dependency
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.SolverInstallPlan
( SolverInstallPlan, SolverPlanPackage )
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.Setup
( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)
, RepoContext(..) )
import Distribution.Client.Sandbox.PackageEnvironment
( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,
userPackageEnvironmentFile )
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PkgConfigDb
import Distribution.Solver.Types.SolverId
import Distribution.Package
( Package, packageId, packageName, packageVersion )
import Distribution.Simple.Compiler
( Compiler, compilerInfo, PackageDBStack )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.Program
( ProgramDb )
import Distribution.Simple.Setup
( fromFlag, fromFlagOrDefault, flagToMaybe )
import Distribution.Simple.Utils
( die', notice, debug, writeFileAtomic, toUTF8LBS)
import Distribution.System
( Platform )
import Distribution.Version
( thisVersion )
freeze :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO ()
freeze :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO ()
freeze Verbosity
verbosity PackageDBStack
packageDBs RepoContext
repoCtxt Compiler
comp Platform
platform ProgramDb
progdb
GlobalFlags
globalFlags FreezeFlags
freezeFlags = do
[SolverPlanPackage]
pkgs <- Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO [SolverPlanPackage]
getFreezePkgs
Verbosity
verbosity PackageDBStack
packageDBs RepoContext
repoCtxt Compiler
comp Platform
platform ProgramDb
progdb
GlobalFlags
globalFlags FreezeFlags
freezeFlags
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SolverPlanPackage]
pkgs
then Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"No packages to be frozen. "
forall a. [a] -> [a] -> [a]
++ String
"As this package has no dependencies."
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 frozen:"
forall a. a -> [a] -> [a]
: forall pkg. Package pkg => [pkg] -> [String]
formatPkgs [SolverPlanPackage]
pkgs
else forall pkg.
Package pkg =>
Verbosity -> GlobalFlags -> [pkg] -> IO ()
freezePackages Verbosity
verbosity GlobalFlags
globalFlags [SolverPlanPackage]
pkgs
where
dryRun :: Bool
dryRun = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag Bool
freezeDryRun FreezeFlags
freezeFlags)
getFreezePkgs :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO [SolverPlanPackage]
getFreezePkgs :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO [SolverPlanPackage]
getFreezePkgs Verbosity
verbosity PackageDBStack
packageDBs RepoContext
repoCtxt Compiler
comp Platform
platform ProgramDb
progdb
GlobalFlags
_ FreezeFlags
freezeFlags = do
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)
[String -> UserTarget
UserTargetLocalDir String
"."]
[PackageSpecifier UnresolvedSourcePackage] -> IO ()
sanityCheck [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
Verbosity
-> Compiler
-> Platform
-> FreezeFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO [SolverPlanPackage]
planPackages
Verbosity
verbosity Compiler
comp Platform
platform FreezeFlags
freezeFlags
InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb PkgConfigDb
pkgConfigDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
where
sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO ()
sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO ()
sanityCheck [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [PackageSpecifier UnresolvedSourcePackage
n | n :: PackageSpecifier UnresolvedSourcePackage
n@(NamedPackage PackageName
_ [PackageProperty]
_) <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers]) forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"internal error: 'resolveUserTargets' returned "
forall a. [a] -> [a] -> [a]
++ String
"unexpected named package specifiers!"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"internal error: 'resolveUserTargets' returned "
forall a. [a] -> [a] -> [a]
++ String
"unexpected source package specifiers!"
planPackages :: Verbosity
-> Compiler
-> Platform
-> FreezeFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO [SolverPlanPackage]
planPackages :: Verbosity
-> Compiler
-> Platform
-> FreezeFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> IO [SolverPlanPackage]
planPackages Verbosity
verbosity Compiler
comp Platform
platform FreezeFlags
freezeFlags
InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb PkgConfigDb
pkgConfigDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers = do
Solver
solver <- Verbosity -> PreSolver -> CompilerInfo -> IO Solver
chooseSolver Verbosity
verbosity
(forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag PreSolver
freezeSolver FreezeFlags
freezeFlags)) (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 a b. (a -> b) -> a -> b
$ SolverInstallPlan
-> [PackageSpecifier UnresolvedSourcePackage]
-> [SolverPlanPackage]
pruneInstallPlan SolverInstallPlan
installPlan [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
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 pkg :: PackageName
pkg = forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget PackageSpecifier UnresolvedSourcePackage
pkgSpecifier
pc :: PackageConstraint
pc = ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint (PackageName -> ConstraintScope
scopeToplevel PackageName
pkg)
([OptionalStanza] -> PackageProperty
PackagePropertyStanzas [OptionalStanza]
stanzas)
in PackageConstraint -> ConstraintSource -> LabeledPackageConstraint
LabeledPackageConstraint PackageConstraint
pc ConstraintSource
ConstraintSourceFreeze
| PackageSpecifier UnresolvedSourcePackage
pkgSpecifier <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers ]
forall a b. (a -> b) -> a -> b
$ InstalledPackageIndex
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
standardInstallPolicy InstalledPackageIndex
installedPkgIndex SourcePackageDb
sourcePkgDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
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
$ FreezeFlags -> Flag Bool
freezeTests FreezeFlags
freezeFlags
benchmarksEnabled :: Bool
benchmarksEnabled = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall a b. (a -> b) -> a -> b
$ FreezeFlags -> Flag Bool
freezeBenchmarks FreezeFlags
freezeFlags
reorderGoals :: ReorderGoals
reorderGoals = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag ReorderGoals
freezeReorderGoals FreezeFlags
freezeFlags)
countConflicts :: CountConflicts
countConflicts = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag CountConflicts
freezeCountConflicts FreezeFlags
freezeFlags)
fineGrainedConflicts :: FineGrainedConflicts
fineGrainedConflicts = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag FineGrainedConflicts
freezeFineGrainedConflicts FreezeFlags
freezeFlags)
minimizeConflictSet :: MinimizeConflictSet
minimizeConflictSet = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag MinimizeConflictSet
freezeMinimizeConflictSet FreezeFlags
freezeFlags)
independentGoals :: IndependentGoals
independentGoals = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag IndependentGoals
freezeIndependentGoals FreezeFlags
freezeFlags)
shadowPkgs :: ShadowPkgs
shadowPkgs = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag ShadowPkgs
freezeShadowPkgs FreezeFlags
freezeFlags)
strongFlags :: StrongFlags
strongFlags = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag StrongFlags
freezeStrongFlags FreezeFlags
freezeFlags)
maxBackjumps :: Int
maxBackjumps = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag Int
freezeMaxBackjumps FreezeFlags
freezeFlags)
allowBootLibInstalls :: AllowBootLibInstalls
allowBootLibInstalls = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag AllowBootLibInstalls
freezeAllowBootLibInstalls FreezeFlags
freezeFlags)
onlyConstrained :: OnlyConstrained
onlyConstrained = forall a. WithCallStack (Flag a -> a)
fromFlag (FreezeFlags -> Flag OnlyConstrained
freezeOnlyConstrained FreezeFlags
freezeFlags)
pruneInstallPlan :: SolverInstallPlan
-> [PackageSpecifier UnresolvedSourcePackage]
-> [SolverPlanPackage]
pruneInstallPlan :: SolverInstallPlan
-> [PackageSpecifier UnresolvedSourcePackage]
-> [SolverPlanPackage]
pruneInstallPlan SolverInstallPlan
installPlan [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers =
forall {pkg} {pkg}.
(Package pkg, Package pkg) =>
[pkg] -> [pkg] -> [pkg]
removeSelf [SolverId]
pkgIds forall a b. (a -> b) -> a -> b
$
SolverInstallPlan -> [SolverId] -> [SolverPlanPackage]
SolverInstallPlan.dependencyClosure SolverInstallPlan
installPlan [SolverId]
pkgIds
where
pkgIds :: [SolverId]
pkgIds = [ PackageId -> SolverId
PlannedId (forall pkg. Package pkg => pkg -> PackageId
packageId UnresolvedSourcePackage
pkg)
| SpecificSourcePackage UnresolvedSourcePackage
pkg <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers ]
removeSelf :: [pkg] -> [pkg] -> [pkg]
removeSelf [pkg
thisPkg] = forall a. (a -> Bool) -> [a] -> [a]
filter (\pkg
pp -> forall pkg. Package pkg => pkg -> PackageId
packageId pkg
pp forall a. Eq a => a -> a -> Bool
/= forall pkg. Package pkg => pkg -> PackageId
packageId pkg
thisPkg)
removeSelf [pkg]
_ = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"internal error: 'pruneInstallPlan' given "
forall a. [a] -> [a] -> [a]
++ String
"unexpected package specifiers!"
freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()
freezePackages :: forall pkg.
Package pkg =>
Verbosity -> GlobalFlags -> [pkg] -> IO ()
freezePackages Verbosity
verbosity GlobalFlags
globalFlags [pkg]
pkgs = do
PackageEnvironment
pkgEnv <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SavedConfig -> PackageEnvironment
createPkgEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> SavedConfig
addFrozenConstraints) forall a b. (a -> b) -> a -> b
$
Verbosity -> String -> Maybe String -> IO SavedConfig
loadUserConfig Verbosity
verbosity String
""
(forall a. Flag a -> Maybe a
flagToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalFlags -> Flag String
globalConstraintsFile forall a b. (a -> b) -> a -> b
$ GlobalFlags
globalFlags)
String -> ByteString -> IO ()
writeFileAtomic String
userPackageEnvironmentFile forall a b. (a -> b) -> a -> b
$ PackageEnvironment -> ByteString
showPkgEnv PackageEnvironment
pkgEnv
where
addFrozenConstraints :: SavedConfig -> SavedConfig
addFrozenConstraints SavedConfig
config =
SavedConfig
config {
savedConfigureExFlags :: ConfigExFlags
savedConfigureExFlags = (SavedConfig -> ConfigExFlags
savedConfigureExFlags SavedConfig
config) {
configExConstraints :: [(UserConstraint, ConstraintSource)]
configExConstraints = forall a b. (a -> b) -> [a] -> [b]
map forall {pkg}.
Package pkg =>
pkg -> (UserConstraint, ConstraintSource)
constraint [pkg]
pkgs
}
}
constraint :: pkg -> (UserConstraint, ConstraintSource)
constraint pkg
pkg =
(forall {pkg}. Package pkg => pkg -> UserConstraint
pkgIdToConstraint forall a b. (a -> b) -> a -> b
$ forall pkg. Package pkg => pkg -> PackageId
packageId pkg
pkg
,String -> ConstraintSource
ConstraintSourceUserConfig String
userPackageEnvironmentFile)
where
pkgIdToConstraint :: pkg -> UserConstraint
pkgIdToConstraint pkg
pkgId =
UserConstraintScope -> PackageProperty -> UserConstraint
UserConstraint (UserQualifier -> PackageName -> UserConstraintScope
UserQualified UserQualifier
UserQualToplevel (forall pkg. Package pkg => pkg -> PackageName
packageName pkg
pkgId))
(VersionRange -> PackageProperty
PackagePropertyVersion forall a b. (a -> b) -> a -> b
$ Version -> VersionRange
thisVersion (forall pkg. Package pkg => pkg -> Version
packageVersion pkg
pkgId))
createPkgEnv :: SavedConfig -> PackageEnvironment
createPkgEnv SavedConfig
config = forall a. Monoid a => a
mempty { pkgEnvSavedConfig :: SavedConfig
pkgEnvSavedConfig = SavedConfig
config }
showPkgEnv :: PackageEnvironment -> ByteString
showPkgEnv = String -> ByteString
toUTF8LBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageEnvironment -> String
showPackageEnvironment
formatPkgs :: Package pkg => [pkg] -> [String]
formatPkgs :: forall pkg. Package pkg => [pkg] -> [String]
formatPkgs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ PackageId -> String
showPkg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageId
packageId
where
showPkg :: PackageId -> String
showPkg PackageId
pid = PackageId -> String
name PackageId
pid forall a. [a] -> [a] -> [a]
++ String
" == " forall a. [a] -> [a] -> [a]
++ PackageId -> String
version PackageId
pid
name :: PackageId -> String
name = forall a. Pretty a => a -> String
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageName
packageName
version :: PackageId -> String
version = forall a. Pretty a => a -> String
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> Version
packageVersion