cabal-install-1.24.0.0: Distribution/Client/Freeze.hs
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Freeze
-- Copyright : (c) David Himmelstrup 2005
-- Duncan Coutts 2011
-- License : BSD-like
--
-- Maintainer : cabal-devel@gmail.com
-- Stability : provisional
-- Portability : portable
--
-- The cabal freeze command
-----------------------------------------------------------------------------
module Distribution.Client.Freeze (
freeze, getFreezePkgs
) where
import Distribution.Client.Config ( SavedConfig(..) )
import Distribution.Client.Types
import Distribution.Client.Targets
import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
( ConstraintSource(..), LabeledPackageConstraint(..) )
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.InstallPlan
( InstallPlan, PlanPackage )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.PkgConfigDb
( PkgConfigDb, readPkgConfigDb )
import Distribution.Client.Setup
( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)
, RepoContext(..) )
import Distribution.Client.Sandbox.PackageEnvironment
( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,
userPackageEnvironmentFile )
import Distribution.Client.Sandbox.Types
( SandboxPackageInfo(..) )
import Distribution.Package
( Package, packageId, packageName, packageVersion )
import Distribution.Simple.Compiler
( Compiler, compilerInfo, PackageDBStack )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Setup
( fromFlag, fromFlagOrDefault, flagToMaybe )
import Distribution.Simple.Utils
( die, notice, debug, writeFileAtomic )
import Distribution.System
( Platform )
import Distribution.Text
( display )
import Distribution.Verbosity
( Verbosity )
import Control.Monad
( when )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
( mempty )
#endif
import Data.Version
( showVersion )
import Distribution.Version
( thisVersion )
-- ------------------------------------------------------------
-- * The freeze command
-- ------------------------------------------------------------
-- | Freeze all of the dependencies by writing a constraints section
-- constraining each dependency to an exact version.
--
freeze :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramConfiguration
-> Maybe SandboxPackageInfo
-> GlobalFlags
-> FreezeFlags
-> IO ()
freeze verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo
globalFlags freezeFlags = do
pkgs <- getFreezePkgs
verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo
globalFlags freezeFlags
if null pkgs
then notice verbosity $ "No packages to be frozen. "
++ "As this package has no dependencies."
else if dryRun
then notice verbosity $ unlines $
"The following packages would be frozen:"
: formatPkgs pkgs
else freezePackages verbosity globalFlags pkgs
where
dryRun = fromFlag (freezeDryRun freezeFlags)
-- | Get the list of packages whose versions would be frozen by the @freeze@
-- command.
getFreezePkgs :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> Platform
-> ProgramConfiguration
-> Maybe SandboxPackageInfo
-> GlobalFlags
-> FreezeFlags
-> IO [PlanPackage]
getFreezePkgs verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo
globalFlags freezeFlags = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repoCtxt
pkgConfigDb <- readPkgConfigDb verbosity conf
pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
[UserTargetLocalDir "."]
sanityCheck pkgSpecifiers
planPackages
verbosity comp platform mSandboxPkgInfo freezeFlags
installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers
where
sanityCheck pkgSpecifiers = do
when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
die $ "internal error: 'resolveUserTargets' returned "
++ "unexpected named package specifiers!"
when (length pkgSpecifiers /= 1) $
die $ "internal error: 'resolveUserTargets' returned "
++ "unexpected source package specifiers!"
planPackages :: Verbosity
-> Compiler
-> Platform
-> Maybe SandboxPackageInfo
-> FreezeFlags
-> InstalledPackageIndex
-> SourcePackageDb
-> PkgConfigDb
-> [PackageSpecifier SourcePackage]
-> IO [PlanPackage]
planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do
solver <- chooseSolver verbosity
(fromFlag (freezeSolver freezeFlags)) (compilerInfo comp)
notice verbosity "Resolving dependencies..."
installPlan <- foldProgress logMsg die return $
resolveDependencies
platform (compilerInfo comp) pkgConfigDb
solver
resolverParams
return $ pruneInstallPlan installPlan pkgSpecifiers
where
resolverParams =
setMaxBackjumps (if maxBackjumps < 0 then Nothing
else Just maxBackjumps)
. setIndependentGoals independentGoals
. setReorderGoals reorderGoals
. setShadowPkgs shadowPkgs
. setStrongFlags strongFlags
. addConstraints
[ let pkg = pkgSpecifierTarget pkgSpecifier
pc = PackageConstraintStanzas pkg stanzas
in LabeledPackageConstraint pc ConstraintSourceFreeze
| pkgSpecifier <- pkgSpecifiers ]
. maybe id applySandboxInstallPolicy mSandboxPkgInfo
$ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
logMsg message rest = debug verbosity message >> rest
stanzas = [ TestStanzas | testsEnabled ]
++ [ BenchStanzas | benchmarksEnabled ]
testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags
benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags
reorderGoals = fromFlag (freezeReorderGoals freezeFlags)
independentGoals = fromFlag (freezeIndependentGoals freezeFlags)
shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags)
strongFlags = fromFlag (freezeStrongFlags freezeFlags)
maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags)
-- | Remove all unneeded packages from an install plan.
--
-- A package is unneeded if it is either
--
-- 1) the package that we are freezing, or
--
-- 2) not a dependency (directly or transitively) of the package we are
-- freezing. This is useful for removing previously installed packages
-- which are no longer required from the install plan.
pruneInstallPlan :: InstallPlan
-> [PackageSpecifier SourcePackage]
-> [PlanPackage]
pruneInstallPlan installPlan pkgSpecifiers =
removeSelf pkgIds $
InstallPlan.dependencyClosure installPlan (map fakeUnitId pkgIds)
where
pkgIds = [ packageId pkg
| SpecificSourcePackage pkg <- pkgSpecifiers ]
removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)
removeSelf _ = error $ "internal error: 'pruneInstallPlan' given "
++ "unexpected package specifiers!"
freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()
freezePackages verbosity globalFlags pkgs = do
pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $
loadUserConfig verbosity "" (flagToMaybe . globalConstraintsFile $ globalFlags)
writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv
where
addFrozenConstraints config =
config {
savedConfigureExFlags = (savedConfigureExFlags config) {
configExConstraints = map constraint pkgs
}
}
constraint pkg =
(pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig userPackageEnvironmentFile)
where
pkgIdToConstraint pkgId =
UserConstraintVersion (packageName pkgId)
(thisVersion $ packageVersion pkgId)
createPkgEnv config = mempty { pkgEnvSavedConfig = config }
showPkgEnv = BS.Char8.pack . showPackageEnvironment
formatPkgs :: Package pkg => [pkg] -> [String]
formatPkgs = map $ showPkg . packageId
where
showPkg pid = name pid ++ " == " ++ version pid
name = display . packageName
version = showVersion . packageVersion