cabal-install-1.24.0.0: 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,
hideInstalledPackagesSpecificByUnitId,
hideInstalledPackagesSpecificBySourcePackageId,
hideInstalledPackagesAllVersions,
removeUpperBounds,
addDefaultSetupDependencies,
) where
import Distribution.Client.Dependency.TopDown
( topDownResolver )
import Distribution.Client.Dependency.Modular
( modularResolver, SolverConfig(..) )
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.PkgConfigDb (PkgConfigDb)
import Distribution.Client.Types
( SourcePackageDb(SourcePackageDb), SourcePackage(..)
, ConfiguredPackage(..), ConfiguredId(..)
, OptionalStanza(..), enableStanzas )
import Distribution.Client.Dependency.Types
( PreSolver(..), Solver(..), DependencyResolver, ResolverPackage(..)
, PackageConstraint(..), showPackageConstraint
, LabeledPackageConstraint(..), unlabelPackageConstraint
, ConstraintSource(..), showConstraintSource
, PackagePreferences(..), InstalledPreference(..)
, PackagesPreferenceDefault(..)
, Progress(..), foldProgress )
import Distribution.Client.Sandbox.Types
( SandboxPackageInfo(..) )
import Distribution.Client.Targets
import Distribution.Client.ComponentDeps (ComponentDeps)
import qualified Distribution.Client.ComponentDeps as CD
import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Package
( PackageName(..), PackageIdentifier(PackageIdentifier), PackageId
, Package(..), packageName, packageVersion
, UnitId, Dependency(Dependency))
import qualified Distribution.PackageDescription as PD
import qualified Distribution.PackageDescription.Configuration as PD
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
import Distribution.Client.PackageUtils
( externalBuildDepends )
import Distribution.Version
( VersionRange, Version(..), anyVersion, orLaterVersion, thisVersion
, withinRange, simplifyVersionRange )
import Distribution.Compiler
( CompilerInfo(..) )
import Distribution.System
( Platform )
import Distribution.Client.Utils
( duplicates, duplicatesBy, mergeBy, MergeResult(..) )
import Distribution.Simple.Utils
( comparing, warn, info )
import Distribution.Simple.Configure
( relaxPackageDeps )
import Distribution.Simple.Setup
( AllowNewer(..) )
import Distribution.Text
( display )
import Distribution.Verbosity
( Verbosity )
import Data.List
( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub )
import Data.Function (on)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (Set)
import Control.Exception
( assert )
-- ------------------------------------------------------------
-- * 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 :: [LabeledPackageConstraint],
depResolverPreferences :: [PackagePreference],
depResolverPreferenceDefault :: PackagesPreferenceDefault,
depResolverInstalledPkgIndex :: InstalledPackageIndex,
depResolverSourcePkgIndex :: PackageIndex.PackageIndex SourcePackage,
depResolverReorderGoals :: Bool,
depResolverIndependentGoals :: Bool,
depResolverAvoidReinstalls :: Bool,
depResolverShadowPkgs :: Bool,
depResolverStrongFlags :: Bool,
depResolverMaxBackjumps :: Maybe Int
}
showDepResolverParams :: DepResolverParams -> String
showDepResolverParams p =
"targets: " ++ intercalate ", " (map display (depResolverTargets p))
++ "\nconstraints: "
++ concatMap (("\n " ++) . showLabeledConstraint)
(depResolverConstraints p)
++ "\npreferences: "
++ concatMap (("\n " ++) . showPackagePreference)
(depResolverPreferences p)
++ "\nstrategy: " ++ show (depResolverPreferenceDefault p)
++ "\nreorder goals: " ++ show (depResolverReorderGoals p)
++ "\nindependent goals: " ++ show (depResolverIndependentGoals p)
++ "\navoid reinstalls: " ++ show (depResolverAvoidReinstalls p)
++ "\nshadow packages: " ++ show (depResolverShadowPkgs p)
++ "\nstrong flags: " ++ show (depResolverStrongFlags p)
++ "\nmax backjumps: " ++ maybe "infinite" show
(depResolverMaxBackjumps p)
where
showLabeledConstraint :: LabeledPackageConstraint -> String
showLabeledConstraint (LabeledPackageConstraint pc src) =
showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"
-- | 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
-- | If we would prefer to enable these optional stanzas
-- (i.e. test suites and/or benchmarks)
| PackageStanzasPreference PackageName [OptionalStanza]
-- | Provide a textual representation of a package preference
-- for debugging purposes.
--
showPackagePreference :: PackagePreference -> String
showPackagePreference (PackageVersionPreference pn vr) =
display pn ++ " " ++ display (simplifyVersionRange vr)
showPackagePreference (PackageInstalledPreference pn ip) =
display pn ++ " " ++ show ip
showPackagePreference (PackageStanzasPreference pn st) =
display pn ++ " " ++ show st
basicDepResolverParams :: InstalledPackageIndex
-> 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 :: [LabeledPackageConstraint]
-> 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 =
[ LabeledPackageConstraint
(PackageConstraintInstalled pkgname)
ConstraintSourceNonUpgradeablePackage
| notElem (PackageName "base") (depResolverTargets params)
, pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp"
, "integer-simple" ]
, 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
}
hideInstalledPackagesSpecificByUnitId :: [UnitId]
-> DepResolverParams
-> DepResolverParams
hideInstalledPackagesSpecificByUnitId pkgids params =
--TODO: this should work using exclude constraints instead
params {
depResolverInstalledPkgIndex =
foldl' (flip InstalledPackageIndex.deleteUnitId)
(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 =
hideInstalledPackagesSpecificByUnitId pkgids params
where
pkgids = map Installed.installedUnitId
. InstalledPackageIndex.reverseDependencyClosure
(depResolverInstalledPkgIndex params)
. map (Installed.installedUnitId . fst)
. InstalledPackageIndex.brokenPackages
$ depResolverInstalledPkgIndex params
-- | Remove upper bounds in dependencies using the policy specified by the
-- 'AllowNewer' argument (all/some/none).
--
-- Note: It's important to apply 'removeUpperBounds' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
--
removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams
removeUpperBounds AllowNewerNone params = params
removeUpperBounds allowNewer params =
params {
depResolverSourcePkgIndex = sourcePkgIndex'
}
where
sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params
relaxDeps :: SourcePackage -> SourcePackage
relaxDeps srcPkg = srcPkg {
packageDescription = relaxPackageDeps allowNewer
(packageDescription srcPkg)
}
-- | Supply defaults for packages without explicit Setup dependencies
--
-- Note: It's important to apply 'addDefaultSetupDepends' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
--
addDefaultSetupDependencies :: (SourcePackage -> Maybe [Dependency])
-> DepResolverParams -> DepResolverParams
addDefaultSetupDependencies defaultSetupDeps params =
params {
depResolverSourcePkgIndex =
fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)
}
where
applyDefaultSetupDeps :: SourcePackage -> SourcePackage
applyDefaultSetupDeps srcpkg =
srcpkg {
packageDescription = gpkgdesc {
PD.packageDescription = pkgdesc {
PD.setupBuildInfo =
case PD.setupBuildInfo pkgdesc of
Just sbi -> Just sbi
Nothing -> case defaultSetupDeps srcpkg of
Nothing -> Nothing
Just deps -> Just PD.SetupBuildInfo {
PD.defaultSetupDepends = True,
PD.setupDepends = deps
}
}
}
}
where
gpkgdesc = packageDescription srcpkg
pkgdesc = PD.packageDescription gpkgdesc
upgradeDependencies :: DepResolverParams -> DepResolverParams
upgradeDependencies = setPreferenceDefault PreferAllLatest
reinstallTargets :: DepResolverParams -> DepResolverParams
reinstallTargets params =
hideInstalledPackagesAllVersions (depResolverTargets params) params
standardInstallPolicy :: InstalledPackageIndex
-> 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 ]
. addDefaultSetupDependencies mkDefaultSetupDeps
. addSourcePackages
[ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
$ basicDepResolverParams
installedPkgIndex sourcePkgIndex
where
-- Force Cabal >= 1.24 dep when the package is affected by #3199.
mkDefaultSetupDeps :: SourcePackage -> Maybe [Dependency]
mkDefaultSetupDeps srcpkg | affected =
Just [Dependency (PackageName "Cabal")
(orLaterVersion $ Version [1,24] [])]
| otherwise = Nothing
where
gpkgdesc = packageDescription srcpkg
pkgdesc = PD.packageDescription gpkgdesc
bt = fromMaybe PD.Custom (PD.buildType pkgdesc)
affected = bt == PD.Custom && hasBuildableFalse gpkgdesc
-- Does this package contain any components with non-empty 'build-depends'
-- and a 'buildable' field that could potentially be set to 'False'? False
-- positives are possible.
hasBuildableFalse :: PD.GenericPackageDescription -> Bool
hasBuildableFalse gpkg =
not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions))
where
buildableConditions = PD.extractConditions PD.buildable gpkg
noDepConditions = PD.extractConditions
(null . PD.targetBuildDepends) gpkg
alwaysTrue (PD.Lit True) = True
alwaysTrue _ = False
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
[ let pc = PackageConstraintVersion (packageName pkg)
(thisVersion (packageVersion pkg))
in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep
| 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 -> CompilerInfo -> IO Solver
chooseSolver verbosity preSolver _cinfo =
case preSolver of
AlwaysTopDown -> do
warn verbosity "Topdown solver is deprecated"
return TopDown
AlwaysModular -> do
return Modular
Choose -> do
info verbosity "Choosing modular solver."
return Modular
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
-> CompilerInfo
-> PkgConfigDb
-> Solver
-> DepResolverParams
-> Progress String String InstallPlan
--TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
resolveDependencies platform comp _pkgConfigDB _solver params
| null (depResolverTargets params)
= return (validateSolverResult platform comp indGoals [])
where
indGoals = depResolverIndependentGoals params
resolveDependencies platform comp pkgConfigDB solver params =
Step (showDepResolverParams finalparams)
$ fmap (validateSolverResult platform comp indGoals)
$ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
shadowing strFlags maxBkjumps)
platform comp installedPkgIndex sourcePkgIndex
pkgConfigDB preferences constraints targets
where
finalparams @ (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
-- | 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)
(stanzasPref pkgname)
where
versionPref pkgname =
fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)
versionPrefs = Map.fromListWith (++)
[(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 -> const PreferLatest
PreferAllInstalled -> const 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
stanzasPref pkgname =
fromMaybe [] (Map.lookup pkgname stanzasPrefs)
stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b))
[ (pkgname, pref)
| PackageStanzasPreference pkgname pref <- prefs ]
-- ------------------------------------------------------------
-- * Checking the result of the solver
-- ------------------------------------------------------------
-- | 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.
--
validateSolverResult :: Platform
-> CompilerInfo
-> Bool
-> [ResolverPackage]
-> InstallPlan
validateSolverResult platform comp indepGoals pkgs =
case planPackagesProblems platform comp pkgs of
[] -> case InstallPlan.new indepGoals index of
Right plan -> plan
Left problems -> error (formatPlanProblems problems)
problems -> error (formatPkgProblems problems)
where
index = InstalledPackageIndex.fromList (map toPlanPackage pkgs)
toPlanPackage (PreExisting pkg) = InstallPlan.PreExisting pkg
toPlanPackage (Configured pkg) = InstallPlan.Configured pkg
formatPkgProblems = formatProblemMessage . map showPlanPackageProblem
formatPlanProblems = formatProblemMessage . map InstallPlan.showPlanProblem
formatProblemMessage problems =
unlines $
"internal error: could not construct a valid install plan."
: "The proposed (invalid) plan contained the following problems:"
: problems
++ "Proposed plan:"
: [InstallPlan.showPlanIndex index]
data PlanPackageProblem =
InvalidConfiguredPackage ConfiguredPackage [PackageProblem]
showPlanPackageProblem :: PlanPackageProblem -> String
showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =
"Package " ++ display (packageId pkg)
++ " has an invalid configuration, in particular:\n"
++ unlines [ " " ++ showPackageProblem problem
| problem <- packageProblems ]
planPackagesProblems :: Platform -> CompilerInfo
-> [ResolverPackage]
-> [PlanPackageProblem]
planPackagesProblems platform cinfo pkgs =
[ InvalidConfiguredPackage pkg packageProblems
| Configured pkg <- pkgs
, let packageProblems = configuredPackageProblems platform cinfo pkg
, not (null packageProblems) ]
data PackageProblem = DuplicateFlag PD.FlagName
| MissingFlag PD.FlagName
| ExtraFlag PD.FlagName
| DuplicateDeps [PackageId]
| MissingDep Dependency
| ExtraDep PackageId
| InvalidDep Dependency PackageId
showPackageProblem :: PackageProblem -> String
showPackageProblem (DuplicateFlag (PD.FlagName flag)) =
"duplicate flag in the flag assignment: " ++ flag
showPackageProblem (MissingFlag (PD.FlagName flag)) =
"missing an assignment for the flag: " ++ flag
showPackageProblem (ExtraFlag (PD.FlagName flag)) =
"extra flag given that is not used by the package: " ++ flag
showPackageProblem (DuplicateDeps pkgids) =
"duplicate packages specified as selected dependencies: "
++ intercalate ", " (map display pkgids)
showPackageProblem (MissingDep dep) =
"the package has a dependency " ++ display dep
++ " but no package has been selected to satisfy it."
showPackageProblem (ExtraDep pkgid) =
"the package configuration specifies " ++ display pkgid
++ " but (with the given flag assignment) the package does not actually"
++ " depend on any version of that package."
showPackageProblem (InvalidDep dep pkgid) =
"the package depends on " ++ display dep
++ " but the configuration specifies " ++ display pkgid
++ " which does not satisfy the dependency."
-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if
-- in the configuration given by the flag assignment, all the package
-- dependencies are satisfied by the specified packages.
--
configuredPackageProblems :: Platform -> CompilerInfo
-> ConfiguredPackage -> [PackageProblem]
configuredPackageProblems platform cinfo
(ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps') =
[ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]
++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ]
++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ]
++ [ DuplicateDeps pkgs
| pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName))
specifiedDeps) ]
++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ]
++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ]
++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps
, not (packageSatisfiesDependency pkgid dep) ]
where
specifiedDeps :: ComponentDeps [PackageId]
specifiedDeps = fmap (map confSrcId) specifiedDeps'
mergedFlags = mergeBy compare
(sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg)))
(sort $ map fst specifiedFlags)
packageSatisfiesDependency
(PackageIdentifier name version)
(Dependency name' versionRange) = assert (name == name') $
version `withinRange` versionRange
dependencyName (Dependency name _) = name
mergedDeps :: [MergeResult Dependency PackageId]
mergedDeps = mergeDeps requiredDeps (CD.flatDeps specifiedDeps)
mergeDeps :: [Dependency] -> [PackageId]
-> [MergeResult Dependency PackageId]
mergeDeps required specified =
let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in
mergeBy
(\dep pkgid -> dependencyName dep `compare` packageName pkgid)
(sortNubOn dependencyName required)
(sortNubOn packageName specified)
-- TODO: It would be nicer to use ComponentDeps here so we can be more
-- precise in our checks. That's a bit tricky though, as this currently
-- relies on the 'buildDepends' field of 'PackageDescription'. (OTOH, that
-- field is deprecated and should be removed anyway.) As long as we _do_
-- use a flat list here, we have to allow for duplicates when we fold
-- specifiedDeps; once we have proper ComponentDeps here we should get rid
-- of the `nubOn` in `mergeDeps`.
requiredDeps :: [Dependency]
requiredDeps =
--TODO: use something lower level than finalizePackageDescription
case finalizePackageDescription specifiedFlags
(const True)
platform cinfo
[]
(enableStanzas stanzas $ packageDescription pkg) of
Right (resolvedPkg, _) ->
externalBuildDepends resolvedPkg
++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)
Left _ ->
error "configuredPackageInvalidDeps internal error"
-- ------------------------------------------------------------
-- * 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 = length . filter (packageVersion pkg `withinRange`) $
preferredVersions
packageConstraints :: PackageName -> VersionRange
packageConstraints pkgname =
Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
packageVersionConstraintMap =
let pcs = map unlabelPackageConstraint constraints
in Map.fromList [ (name, range)
| PackageConstraintVersion name range <- pcs ]
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)