cabal-install-1.20.0.2: Distribution/Client/Dependency.hs
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Dependency
-- Copyright : (c) David Himmelstrup 2005,
-- Bjorn Bringert 2007
-- Duncan Coutts 2008
-- License : BSD-like
--
-- Maintainer : cabal-devel@gmail.com
-- Stability : provisional
-- Portability : portable
--
-- Top level interface to dependency resolution.
-----------------------------------------------------------------------------
module Distribution.Client.Dependency (
-- * The main package dependency resolver
chooseSolver,
resolveDependencies,
Progress(..),
foldProgress,
-- * Alternate, simple resolver that does not do dependencies recursively
resolveWithoutDependencies,
-- * Constructing resolver policies
DepResolverParams(..),
PackageConstraint(..),
PackagesPreferenceDefault(..),
PackagePreference(..),
InstalledPreference(..),
-- ** Standard policy
standardInstallPolicy,
PackageSpecifier(..),
-- ** Sandbox policy
applySandboxInstallPolicy,
-- ** Extra policy options
dontUpgradeNonUpgradeablePackages,
hideBrokenInstalledPackages,
upgradeDependencies,
reinstallTargets,
-- ** Policy utils
addConstraints,
addPreferences,
setPreferenceDefault,
setReorderGoals,
setIndependentGoals,
setAvoidReinstalls,
setShadowPkgs,
setStrongFlags,
setMaxBackjumps,
addSourcePackages,
hideInstalledPackagesSpecificByInstalledPackageId,
hideInstalledPackagesSpecificBySourcePackageId,
hideInstalledPackagesAllVersions,
removeUpperBounds
) where
import Distribution.Client.Dependency.TopDown
( topDownResolver )
import Distribution.Client.Dependency.Modular
( modularResolver, SolverConfig(..) )
import qualified Distribution.Client.PackageIndex as PackageIndex
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Types
( SourcePackageDb(SourcePackageDb)
, SourcePackage(..) )
import Distribution.Client.Dependency.Types
( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..)
, AllowNewer(..), PackagePreferences(..), InstalledPreference(..)
, PackagesPreferenceDefault(..)
, Progress(..), foldProgress )
import Distribution.Client.Sandbox.Types
( SandboxPackageInfo(..) )
import Distribution.Client.Targets
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Package
( PackageName(..), PackageId, Package(..), packageName, packageVersion
, InstalledPackageId, Dependency(Dependency))
import qualified Distribution.PackageDescription as PD
( PackageDescription(..), GenericPackageDescription(..)
, Library(..), Executable(..), TestSuite(..), Benchmark(..), CondTree)
import Distribution.PackageDescription (BuildInfo(targetBuildDepends))
import Distribution.PackageDescription.Configuration (mapCondTree)
import Distribution.Version
( Version(..), VersionRange, anyVersion, thisVersion, withinRange
, removeUpperBound, simplifyVersionRange )
import Distribution.Compiler
( CompilerId(..), CompilerFlavor(..) )
import Distribution.System
( Platform )
import Distribution.Simple.Utils
( comparing, warn, info )
import Distribution.Text
( display )
import Distribution.Verbosity
( Verbosity )
import Data.List (maximumBy, foldl')
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (Set)
-- ------------------------------------------------------------
-- * High level planner policy
-- ------------------------------------------------------------
-- | The set of parameters to the dependency resolver. These parameters are
-- relatively low level but many kinds of high level policies can be
-- implemented in terms of adjustments to the parameters.
--
data DepResolverParams = DepResolverParams {
depResolverTargets :: [PackageName],
depResolverConstraints :: [PackageConstraint],
depResolverPreferences :: [PackagePreference],
depResolverPreferenceDefault :: PackagesPreferenceDefault,
depResolverInstalledPkgIndex :: InstalledPackageIndex.PackageIndex,
depResolverSourcePkgIndex :: PackageIndex.PackageIndex SourcePackage,
depResolverReorderGoals :: Bool,
depResolverIndependentGoals :: Bool,
depResolverAvoidReinstalls :: Bool,
depResolverShadowPkgs :: Bool,
depResolverStrongFlags :: Bool,
depResolverMaxBackjumps :: Maybe Int
}
-- | A package selection preference for a particular package.
--
-- Preferences are soft constraints that the dependency resolver should try to
-- respect where possible. It is not specified if preferences on some packages
-- are more important than others.
--
data PackagePreference =
-- | A suggested constraint on the version number.
PackageVersionPreference PackageName VersionRange
-- | If we prefer versions of packages that are already installed.
| PackageInstalledPreference PackageName InstalledPreference
basicDepResolverParams :: InstalledPackageIndex.PackageIndex
-> PackageIndex.PackageIndex SourcePackage
-> DepResolverParams
basicDepResolverParams installedPkgIndex sourcePkgIndex =
DepResolverParams {
depResolverTargets = [],
depResolverConstraints = [],
depResolverPreferences = [],
depResolverPreferenceDefault = PreferLatestForSelected,
depResolverInstalledPkgIndex = installedPkgIndex,
depResolverSourcePkgIndex = sourcePkgIndex,
depResolverReorderGoals = False,
depResolverIndependentGoals = False,
depResolverAvoidReinstalls = False,
depResolverShadowPkgs = False,
depResolverStrongFlags = False,
depResolverMaxBackjumps = Nothing
}
addTargets :: [PackageName]
-> DepResolverParams -> DepResolverParams
addTargets extraTargets params =
params {
depResolverTargets = extraTargets ++ depResolverTargets params
}
addConstraints :: [PackageConstraint]
-> DepResolverParams -> DepResolverParams
addConstraints extraConstraints params =
params {
depResolverConstraints = extraConstraints
++ depResolverConstraints params
}
addPreferences :: [PackagePreference]
-> DepResolverParams -> DepResolverParams
addPreferences extraPreferences params =
params {
depResolverPreferences = extraPreferences
++ depResolverPreferences params
}
setPreferenceDefault :: PackagesPreferenceDefault
-> DepResolverParams -> DepResolverParams
setPreferenceDefault preferenceDefault params =
params {
depResolverPreferenceDefault = preferenceDefault
}
setReorderGoals :: Bool -> DepResolverParams -> DepResolverParams
setReorderGoals b params =
params {
depResolverReorderGoals = b
}
setIndependentGoals :: Bool -> DepResolverParams -> DepResolverParams
setIndependentGoals b params =
params {
depResolverIndependentGoals = b
}
setAvoidReinstalls :: Bool -> DepResolverParams -> DepResolverParams
setAvoidReinstalls b params =
params {
depResolverAvoidReinstalls = b
}
setShadowPkgs :: Bool -> DepResolverParams -> DepResolverParams
setShadowPkgs b params =
params {
depResolverShadowPkgs = b
}
setStrongFlags :: Bool -> DepResolverParams -> DepResolverParams
setStrongFlags b params =
params {
depResolverStrongFlags = b
}
setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams
setMaxBackjumps n params =
params {
depResolverMaxBackjumps = n
}
-- | Some packages are specific to a given compiler version and should never be
-- upgraded.
dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
dontUpgradeNonUpgradeablePackages params =
addConstraints extraConstraints params
where
extraConstraints =
[ PackageConstraintInstalled pkgname
| all (/=PackageName "base") (depResolverTargets params)
, pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp"
, "integer-simple", "template-haskell" ]
, isInstalled pkgname ]
-- TODO: the top down resolver chokes on the base constraints
-- below when there are no targets and thus no dep on base.
-- Need to refactor constraints separate from needing packages.
isInstalled = not . null
. InstalledPackageIndex.lookupPackageName
(depResolverInstalledPkgIndex params)
addSourcePackages :: [SourcePackage]
-> DepResolverParams -> DepResolverParams
addSourcePackages pkgs params =
params {
depResolverSourcePkgIndex =
foldl (flip PackageIndex.insert)
(depResolverSourcePkgIndex params) pkgs
}
hideInstalledPackagesSpecificByInstalledPackageId :: [InstalledPackageId]
-> DepResolverParams
-> DepResolverParams
hideInstalledPackagesSpecificByInstalledPackageId pkgids params =
--TODO: this should work using exclude constraints instead
params {
depResolverInstalledPkgIndex =
foldl' (flip InstalledPackageIndex.deleteInstalledPackageId)
(depResolverInstalledPkgIndex params) pkgids
}
hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]
-> DepResolverParams
-> DepResolverParams
hideInstalledPackagesSpecificBySourcePackageId pkgids params =
--TODO: this should work using exclude constraints instead
params {
depResolverInstalledPkgIndex =
foldl' (flip InstalledPackageIndex.deleteSourcePackageId)
(depResolverInstalledPkgIndex params) pkgids
}
hideInstalledPackagesAllVersions :: [PackageName]
-> DepResolverParams -> DepResolverParams
hideInstalledPackagesAllVersions pkgnames params =
--TODO: this should work using exclude constraints instead
params {
depResolverInstalledPkgIndex =
foldl' (flip InstalledPackageIndex.deletePackageName)
(depResolverInstalledPkgIndex params) pkgnames
}
hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams
hideBrokenInstalledPackages params =
hideInstalledPackagesSpecificByInstalledPackageId pkgids params
where
pkgids = map Installed.installedPackageId
. InstalledPackageIndex.reverseDependencyClosure
(depResolverInstalledPkgIndex params)
. map (Installed.installedPackageId . fst)
. InstalledPackageIndex.brokenPackages
$ depResolverInstalledPkgIndex params
-- | Remove upper bounds in dependencies using the policy specified by the
-- 'AllowNewer' argument (all/some/none).
removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams
removeUpperBounds allowNewer params =
params {
-- NB: It's important to apply 'removeUpperBounds' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
depResolverSourcePkgIndex = sourcePkgIndex'
}
where
sourcePkgIndex = depResolverSourcePkgIndex params
sourcePkgIndex' = case allowNewer of
AllowNewerNone -> sourcePkgIndex
AllowNewerAll -> fmap relaxAllPackageDeps sourcePkgIndex
AllowNewerSome pkgs -> fmap (relaxSomePackageDeps pkgs) sourcePkgIndex
relaxAllPackageDeps :: SourcePackage -> SourcePackage
relaxAllPackageDeps = onAllBuildDepends doRelax
where
doRelax (Dependency pkgName verRange) =
Dependency pkgName (removeUpperBound verRange)
relaxSomePackageDeps :: [PackageName] -> SourcePackage -> SourcePackage
relaxSomePackageDeps pkgNames = onAllBuildDepends doRelax
where
doRelax d@(Dependency pkgName verRange)
| pkgName `elem` pkgNames = Dependency pkgName
(removeUpperBound verRange)
| otherwise = d
-- Walk a 'GenericPackageDescription' and apply 'f' to all 'build-depends'
-- fields.
onAllBuildDepends :: (Dependency -> Dependency)
-> SourcePackage -> SourcePackage
onAllBuildDepends f srcPkg = srcPkg'
where
gpd = packageDescription srcPkg
pd = PD.packageDescription gpd
condLib = PD.condLibrary gpd
condExes = PD.condExecutables gpd
condTests = PD.condTestSuites gpd
condBenchs = PD.condBenchmarks gpd
f' = onBuildInfo f
onBuildInfo g bi = bi
{ targetBuildDepends = map g (targetBuildDepends bi) }
onLibrary lib = lib { PD.libBuildInfo = f' $ PD.libBuildInfo lib }
onExecutable exe = exe { PD.buildInfo = f' $ PD.buildInfo exe }
onTestSuite tst = tst { PD.testBuildInfo = f' $ PD.testBuildInfo tst }
onBenchmark bmk = bmk { PD.benchmarkBuildInfo =
f' $ PD.benchmarkBuildInfo bmk }
srcPkg' = srcPkg { packageDescription = gpd' }
gpd' = gpd {
PD.packageDescription = pd',
PD.condLibrary = condLib',
PD.condExecutables = condExes',
PD.condTestSuites = condTests',
PD.condBenchmarks = condBenchs'
}
pd' = pd {
PD.buildDepends = map f (PD.buildDepends pd),
PD.library = fmap onLibrary (PD.library pd),
PD.executables = map onExecutable (PD.executables pd),
PD.testSuites = map onTestSuite (PD.testSuites pd),
PD.benchmarks = map onBenchmark (PD.benchmarks pd)
}
condLib' = fmap (onCondTree onLibrary) condLib
condExes' = map (mapSnd $ onCondTree onExecutable) condExes
condTests' = map (mapSnd $ onCondTree onTestSuite) condTests
condBenchs' = map (mapSnd $ onCondTree onBenchmark) condBenchs
mapSnd :: (a -> b) -> (c,a) -> (c,b)
mapSnd = fmap
onCondTree :: (a -> b) -> PD.CondTree v [Dependency] a
-> PD.CondTree v [Dependency] b
onCondTree g = mapCondTree g (map f) id
upgradeDependencies :: DepResolverParams -> DepResolverParams
upgradeDependencies = setPreferenceDefault PreferAllLatest
reinstallTargets :: DepResolverParams -> DepResolverParams
reinstallTargets params =
hideInstalledPackagesAllVersions (depResolverTargets params) params
standardInstallPolicy :: InstalledPackageIndex.PackageIndex
-> SourcePackageDb
-> [PackageSpecifier SourcePackage]
-> DepResolverParams
standardInstallPolicy
installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)
pkgSpecifiers
= addPreferences
[ PackageVersionPreference name ver
| (name, ver) <- Map.toList sourcePkgPrefs ]
. addConstraints
(concatMap pkgSpecifierConstraints pkgSpecifiers)
. addTargets
(map pkgSpecifierTarget pkgSpecifiers)
. hideInstalledPackagesSpecificBySourcePackageId
[ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
. addSourcePackages
[ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
$ basicDepResolverParams
installedPkgIndex sourcePkgIndex
applySandboxInstallPolicy :: SandboxPackageInfo
-> DepResolverParams
-> DepResolverParams
applySandboxInstallPolicy
(SandboxPackageInfo modifiedDeps otherDeps allSandboxPkgs _allDeps)
params
= addPreferences [ PackageInstalledPreference n PreferInstalled
| n <- installedNotModified ]
. addTargets installedNotModified
. addPreferences
[ PackageVersionPreference (packageName pkg)
(thisVersion (packageVersion pkg)) | pkg <- otherDeps ]
. addConstraints
[ PackageConstraintVersion (packageName pkg)
(thisVersion (packageVersion pkg)) | pkg <- modifiedDeps ]
. addTargets [ packageName pkg | pkg <- modifiedDeps ]
. hideInstalledPackagesSpecificBySourcePackageId
[ packageId pkg | pkg <- modifiedDeps ]
-- We don't need to add source packages for add-source deps to the
-- 'installedPkgIndex' since 'getSourcePackages' did that for us.
$ params
where
installedPkgIds =
map fst . InstalledPackageIndex.allPackagesBySourcePackageId
$ allSandboxPkgs
modifiedPkgIds = map packageId modifiedDeps
installedNotModified = [ packageName pkg | pkg <- installedPkgIds,
pkg `notElem` modifiedPkgIds ]
-- ------------------------------------------------------------
-- * Interface to the standard resolver
-- ------------------------------------------------------------
chooseSolver :: Verbosity -> PreSolver -> CompilerId -> IO Solver
chooseSolver _ AlwaysTopDown _ = return TopDown
chooseSolver _ AlwaysModular _ = return Modular
chooseSolver verbosity Choose (CompilerId f v) = do
let chosenSolver | f == GHC && v <= Version [7] [] = TopDown
| otherwise = Modular
msg TopDown = warn verbosity "Falling back to topdown solver for GHC < 7."
msg Modular = info verbosity "Choosing modular solver."
msg chosenSolver
return chosenSolver
runSolver :: Solver -> SolverConfig -> DependencyResolver
runSolver TopDown = const topDownResolver -- TODO: warn about unsupported options
runSolver Modular = modularResolver
-- | Run the dependency solver.
--
-- Since this is potentially an expensive operation, the result is wrapped in a
-- a 'Progress' structure that can be unfolded to provide progress information,
-- logging messages and the final result or an error.
--
resolveDependencies :: Platform
-> CompilerId
-> Solver
-> DepResolverParams
-> Progress String String InstallPlan
--TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
resolveDependencies platform comp _solver params
| null (depResolverTargets params)
= return (mkInstallPlan platform comp [])
resolveDependencies platform comp solver params =
fmap (mkInstallPlan platform comp)
$ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
shadowing strFlags maxBkjumps)
platform comp installedPkgIndex sourcePkgIndex
preferences constraints targets
where
DepResolverParams
targets constraints
prefs defpref
installedPkgIndex
sourcePkgIndex
reorderGoals
indGoals
noReinstalls
shadowing
strFlags
maxBkjumps = dontUpgradeNonUpgradeablePackages
-- TODO:
-- The modular solver can properly deal with broken
-- packages and won't select them. So the
-- 'hideBrokenInstalledPackages' function should be moved
-- into a module that is specific to the top-down solver.
. (if solver /= Modular then hideBrokenInstalledPackages
else id)
$ params
preferences = interpretPackagesPreference
(Set.fromList targets) defpref prefs
-- | Make an install plan from the output of the dep resolver.
-- It checks that the plan is valid, or it's an error in the dep resolver.
--
mkInstallPlan :: Platform
-> CompilerId
-> [InstallPlan.PlanPackage] -> InstallPlan
mkInstallPlan platform comp pkgIndex =
case InstallPlan.new platform comp (PackageIndex.fromList pkgIndex) of
Right plan -> plan
Left problems -> error $ unlines $
"internal error: could not construct a valid install plan."
: "The proposed (invalid) plan contained the following problems:"
: map InstallPlan.showPlanProblem problems
-- | Give an interpretation to the global 'PackagesPreference' as
-- specific per-package 'PackageVersionPreference'.
--
interpretPackagesPreference :: Set PackageName
-> PackagesPreferenceDefault
-> [PackagePreference]
-> (PackageName -> PackagePreferences)
interpretPackagesPreference selected defaultPref prefs =
\pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)
where
versionPref pkgname =
fromMaybe anyVersion (Map.lookup pkgname versionPrefs)
versionPrefs = Map.fromList
[ (pkgname, pref)
| PackageVersionPreference pkgname pref <- prefs ]
installPref pkgname =
fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)
installPrefs = Map.fromList
[ (pkgname, pref)
| PackageInstalledPreference pkgname pref <- prefs ]
installPrefDefault = case defaultPref of
PreferAllLatest -> \_ -> PreferLatest
PreferAllInstalled -> \_ -> PreferInstalled
PreferLatestForSelected -> \pkgname ->
-- When you say cabal install foo, what you really mean is, prefer the
-- latest version of foo, but the installed version of everything else
if pkgname `Set.member` selected then PreferLatest
else PreferInstalled
-- ------------------------------------------------------------
-- * Simple resolver that ignores dependencies
-- ------------------------------------------------------------
-- | A simplistic method of resolving a list of target package names to
-- available packages.
--
-- Specifically, it does not consider package dependencies at all. Unlike
-- 'resolveDependencies', no attempt is made to ensure that the selected
-- packages have dependencies that are satisfiable or consistent with
-- each other.
--
-- It is suitable for tasks such as selecting packages to download for user
-- inspection. It is not suitable for selecting packages to install.
--
-- Note: if no installed package index is available, it is OK to pass 'mempty'.
-- It simply means preferences for installed packages will be ignored.
--
resolveWithoutDependencies :: DepResolverParams
-> Either [ResolveNoDepsError] [SourcePackage]
resolveWithoutDependencies (DepResolverParams targets constraints
prefs defpref installedPkgIndex sourcePkgIndex
_reorderGoals _indGoals _avoidReinstalls
_shadowing _strFlags _maxBjumps) =
collectEithers (map selectPackage targets)
where
selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage
selectPackage pkgname
| null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions
| otherwise = Right $! maximumBy bestByPrefs choices
where
-- Constraints
requiredVersions = packageConstraints pkgname
pkgDependency = Dependency pkgname requiredVersions
choices = PackageIndex.lookupDependency sourcePkgIndex
pkgDependency
-- Preferences
PackagePreferences preferredVersions preferInstalled
= packagePreferences pkgname
bestByPrefs = comparing $ \pkg ->
(installPref pkg, versionPref pkg, packageVersion pkg)
installPref = case preferInstalled of
PreferLatest -> const False
PreferInstalled -> not . null
. InstalledPackageIndex.lookupSourcePackageId
installedPkgIndex
. packageId
versionPref pkg = packageVersion pkg `withinRange` preferredVersions
packageConstraints :: PackageName -> VersionRange
packageConstraints pkgname =
Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
packageVersionConstraintMap =
Map.fromList [ (name, range)
| PackageConstraintVersion name range <- constraints ]
packagePreferences :: PackageName -> PackagePreferences
packagePreferences = interpretPackagesPreference
(Set.fromList targets) defpref prefs
collectEithers :: [Either a b] -> Either [a] [b]
collectEithers = collect . partitionEithers
where
collect ([], xs) = Right xs
collect (errs,_) = Left errs
partitionEithers :: [Either a b] -> ([a],[b])
partitionEithers = foldr (either left right) ([],[])
where
left a (l, r) = (a:l, r)
right a (l, r) = (l, a:r)
-- | Errors for 'resolveWithoutDependencies'.
--
data ResolveNoDepsError =
-- | A package name which cannot be resolved to a specific package.
-- Also gives the constraint on the version and whether there was
-- a constraint on the package being installed.
ResolveUnsatisfiable PackageName VersionRange
instance Show ResolveNoDepsError where
show (ResolveUnsatisfiable name ver) =
"There is no available version of " ++ display name
++ " that satisfies " ++ display (simplifyVersionRange ver)