cabal-install-1.16.0: Distribution/Client/Dependency/TopDown.hs
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Dependency.Types
-- Copyright : (c) Duncan Coutts 2008
-- License : BSD-like
--
-- Maintainer : cabal-devel@haskell.org
-- Stability : provisional
-- Portability : portable
--
-- Common types for dependency resolution.
-----------------------------------------------------------------------------
module Distribution.Client.Dependency.TopDown (
topDownResolver
) where
import Distribution.Client.Dependency.TopDown.Types
import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints
import Distribution.Client.Dependency.TopDown.Constraints
( Satisfiable(..) )
import Distribution.Client.IndexUtils
( convert )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
( PlanPackage(..) )
import Distribution.Client.Types
( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..)
, enableStanzas )
import Distribution.Client.Dependency.Types
( DependencyResolver, PackageConstraint(..)
, PackagePreferences(..), InstalledPreference(..)
, Progress(..), foldProgress )
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex (PackageIndex)
import Distribution.Package
( PackageName(..), PackageId, Package(..), packageVersion, packageName
, Dependency(Dependency), thisPackageVersion
, simplifyDependency, PackageFixedDeps(depends) )
import Distribution.PackageDescription
( PackageDescription(buildDepends) )
import Distribution.Client.PackageUtils
( externalBuildDepends )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription, flattenPackageDescription )
import Distribution.Version
( VersionRange, withinRange, simplifyVersionRange
, UpperBound(..), asVersionIntervals )
import Distribution.Compiler
( CompilerId )
import Distribution.System
( Platform )
import Distribution.Simple.Utils
( equating, comparing )
import Distribution.Text
( display )
import Data.List
( foldl', maximumBy, minimumBy, nub, sort, sortBy, groupBy )
import Data.Maybe
( fromJust, fromMaybe, catMaybes )
import Data.Monoid
( Monoid(mempty) )
import Control.Monad
( guard )
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.Graph as Graph
import qualified Data.Array as Array
import Control.Exception
( assert )
-- ------------------------------------------------------------
-- * Search state types
-- ------------------------------------------------------------
type Constraints = Constraints.Constraints
InstalledPackageEx UnconfiguredPackage ExclusionReason
type SelectedPackages = PackageIndex SelectedPackage
-- ------------------------------------------------------------
-- * The search tree type
-- ------------------------------------------------------------
data SearchSpace inherited pkg
= ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]
| Failure Failure
-- ------------------------------------------------------------
-- * Traverse a search tree
-- ------------------------------------------------------------
explore :: (PackageName -> PackagePreferences)
-> SearchSpace (SelectedPackages, Constraints, SelectionChanges)
SelectablePackage
-> Progress Log Failure (SelectedPackages, Constraints)
explore _ (Failure failure) = Fail failure
explore _ (ChoiceNode (s,c,_) []) = Done (s,c)
explore pref (ChoiceNode _ choices) =
case [ choice | [choice] <- choices ] of
((_, node'):_) -> Step (logInfo node') (explore pref node')
[] -> Step (logInfo node') (explore pref node')
where
choice = minimumBy (comparing topSortNumber) choices
pkgname = packageName . fst . head $ choice
(_, node') = maximumBy (bestByPref pkgname) choice
where
topSortNumber choice = case fst (head choice) of
InstalledOnly (InstalledPackageEx _ i _) -> i
SourceOnly (UnconfiguredPackage _ i _ _) -> i
InstalledAndSource _ (UnconfiguredPackage _ i _ _) -> i
bestByPref pkgname = case packageInstalledPreference of
PreferLatest ->
comparing (\(p,_) -> ( isPreferred p, packageId p))
PreferInstalled ->
comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p))
where
isInstalled (SourceOnly _) = False
isInstalled _ = True
isPreferred p = packageVersion p `withinRange` preferredVersions
(PackagePreferences preferredVersions packageInstalledPreference)
= pref pkgname
logInfo node = Select selected discarded
where (selected, discarded) = case node of
Failure _ -> ([], [])
ChoiceNode (_,_,changes) _ -> changes
-- ------------------------------------------------------------
-- * Generate a search tree
-- ------------------------------------------------------------
type ConfigurePackage = PackageIndex SelectablePackage
-> SelectablePackage
-> Either [Dependency] SelectedPackage
-- | (packages selected, packages discarded)
type SelectionChanges = ([SelectedPackage], [PackageId])
searchSpace :: ConfigurePackage
-> Constraints
-> SelectedPackages
-> SelectionChanges
-> Set PackageName
-> SearchSpace (SelectedPackages, Constraints, SelectionChanges)
SelectablePackage
searchSpace configure constraints selected changes next =
assert (Set.null (selectedSet `Set.intersection` next)) $
assert (selectedSet `Set.isSubsetOf` Constraints.packages constraints) $
assert (next `Set.isSubsetOf` Constraints.packages constraints) $
ChoiceNode (selected, constraints, changes)
[ [ (pkg, select name pkg)
| pkg <- PackageIndex.lookupPackageName available name ]
| name <- Set.elems next ]
where
available = Constraints.choices constraints
selectedSet = Set.fromList (map packageName (PackageIndex.allPackages selected))
select name pkg = case configure available pkg of
Left missing -> Failure $ ConfigureFailed pkg
[ (dep, Constraints.conflicting constraints dep)
| dep <- missing ]
Right pkg' ->
case constrainDeps pkg' newDeps (addDeps constraints newPkgs) [] of
Left failure -> Failure failure
Right (constraints', newDiscarded) ->
searchSpace configure
constraints' selected' (newSelected, newDiscarded) next'
where
selected' = foldl' (flip PackageIndex.insert) selected newSelected
newSelected =
case Constraints.isPaired constraints (packageId pkg) of
Nothing -> [pkg']
Just pkgid' -> [pkg', pkg'']
where
Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p)
(PackageIndex.lookupPackageId available pkgid')
newPkgs = [ name'
| (Dependency name' _, _) <- newDeps
, null (PackageIndex.lookupPackageName selected' name') ]
newDeps = concatMap packageConstraints newSelected
next' = Set.delete name
$ foldl' (flip Set.insert) next newPkgs
packageConstraints :: SelectedPackage -> [(Dependency, Bool)]
packageConstraints = either installedConstraints availableConstraints
. preferSource
where
preferSource (InstalledOnly pkg) = Left pkg
preferSource (SourceOnly pkg) = Right pkg
preferSource (InstalledAndSource _ pkg) = Right pkg
installedConstraints (InstalledPackageEx _ _ deps) =
[ (thisPackageVersion dep, True)
| dep <- deps ]
availableConstraints (SemiConfiguredPackage _ _ _ deps) =
[ (dep, False) | dep <- deps ]
addDeps :: Constraints -> [PackageName] -> Constraints
addDeps =
foldr $ \pkgname cs ->
case Constraints.addTarget pkgname cs of
Satisfiable cs' () -> cs'
_ -> impossible "addDeps unsatisfiable"
constrainDeps :: SelectedPackage -> [(Dependency, Bool)] -> Constraints
-> [PackageId]
-> Either Failure (Constraints, [PackageId])
constrainDeps pkg [] cs discard =
case addPackageSelectConstraint (packageId pkg) cs of
Satisfiable cs' discard' -> Right (cs', discard' ++ discard)
_ -> impossible "constrainDeps unsatisfiable(1)"
constrainDeps pkg ((dep, installedConstraint):deps) cs discard =
case addPackageDependencyConstraint (packageId pkg) dep installedConstraint cs of
Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)
Unsatisfiable -> impossible "constrainDeps unsatisfiable(2)"
ConflictsWith conflicts ->
Left (DependencyConflict pkg dep installedConstraint conflicts)
-- ------------------------------------------------------------
-- * The main algorithm
-- ------------------------------------------------------------
search :: ConfigurePackage
-> (PackageName -> PackagePreferences)
-> Constraints
-> Set PackageName
-> Progress Log Failure (SelectedPackages, Constraints)
search configure pref constraints =
explore pref . searchSpace configure constraints mempty ([], [])
-- ------------------------------------------------------------
-- * The top level resolver
-- ------------------------------------------------------------
-- | The main exported resolver, with string logging and failure types to fit
-- the standard 'DependencyResolver' interface.
--
topDownResolver :: DependencyResolver
topDownResolver platform comp installedPkgIndex sourcePkgIndex
preferences constraints targets =
mapMessages (topDownResolver' platform comp
(convert installedPkgIndex) sourcePkgIndex
preferences constraints targets)
where
mapMessages :: Progress Log Failure a -> Progress String String a
mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done
-- | The native resolver with detailed structured logging and failure types.
--
topDownResolver' :: Platform -> CompilerId
-> PackageIndex InstalledPackage
-> PackageIndex SourcePackage
-> (PackageName -> PackagePreferences)
-> [PackageConstraint]
-> [PackageName]
-> Progress Log Failure [PlanPackage]
topDownResolver' platform comp installedPkgIndex sourcePkgIndex
preferences constraints targets =
fmap (uncurry finalise)
. (\cs -> search configure preferences cs initialPkgNames)
=<< pruneBottomUp platform comp
=<< addTopLevelConstraints constraints
=<< addTopLevelTargets targets emptyConstraintSet
where
configure = configurePackage platform comp
emptyConstraintSet :: Constraints
emptyConstraintSet = Constraints.empty
(annotateInstalledPackages topSortNumber installedPkgIndex')
(annotateSourcePackages constraints topSortNumber sourcePkgIndex')
(installedPkgIndex', sourcePkgIndex') =
selectNeededSubset installedPkgIndex sourcePkgIndex initialPkgNames
topSortNumber = topologicalSortNumbering installedPkgIndex' sourcePkgIndex'
initialPkgNames = Set.fromList targets
finalise selected' constraints' =
PackageIndex.allPackages
. fst . improvePlan installedPkgIndex' constraints'
. PackageIndex.fromList
$ finaliseSelectedPackages preferences selected' constraints'
addTopLevelTargets :: [PackageName]
-> Constraints
-> Progress a Failure Constraints
addTopLevelTargets [] cs = Done cs
addTopLevelTargets (pkg:pkgs) cs =
case Constraints.addTarget pkg cs of
Satisfiable cs' () -> addTopLevelTargets pkgs cs'
Unsatisfiable -> Fail (NoSuchPackage pkg)
ConflictsWith _conflicts -> impossible "addTopLevelTargets conflicts"
addTopLevelConstraints :: [PackageConstraint] -> Constraints
-> Progress Log Failure Constraints
addTopLevelConstraints [] cs = Done cs
addTopLevelConstraints (PackageConstraintFlags _ _ :deps) cs =
addTopLevelConstraints deps cs
addTopLevelConstraints (PackageConstraintVersion pkg ver:deps) cs =
case addTopLevelVersionConstraint pkg ver cs of
Satisfiable cs' pkgids ->
Step (AppliedVersionConstraint pkg ver pkgids)
(addTopLevelConstraints deps cs')
Unsatisfiable ->
Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)
ConflictsWith conflicts ->
Fail (TopLevelVersionConstraintConflict pkg ver conflicts)
addTopLevelConstraints (PackageConstraintInstalled pkg:deps) cs =
case addTopLevelInstalledConstraint pkg cs of
Satisfiable cs' pkgids ->
Step (AppliedInstalledConstraint pkg InstalledConstraint pkgids)
(addTopLevelConstraints deps cs')
Unsatisfiable ->
Fail (TopLevelInstallConstraintUnsatisfiable pkg InstalledConstraint)
ConflictsWith conflicts ->
Fail (TopLevelInstallConstraintConflict pkg InstalledConstraint conflicts)
addTopLevelConstraints (PackageConstraintSource pkg:deps) cs =
case addTopLevelSourceConstraint pkg cs of
Satisfiable cs' pkgids ->
Step (AppliedInstalledConstraint pkg SourceConstraint pkgids)
(addTopLevelConstraints deps cs')
Unsatisfiable ->
Fail (TopLevelInstallConstraintUnsatisfiable pkg SourceConstraint)
ConflictsWith conflicts ->
Fail (TopLevelInstallConstraintConflict pkg SourceConstraint conflicts)
addTopLevelConstraints (PackageConstraintStanzas _ _ : deps) cs =
addTopLevelConstraints deps cs
-- | Add exclusion on available packages that cannot be configured.
--
pruneBottomUp :: Platform -> CompilerId
-> Constraints -> Progress Log Failure Constraints
pruneBottomUp platform comp constraints =
foldr prune Done (initialPackages constraints) constraints
where
prune pkgs rest cs = foldr addExcludeConstraint rest unconfigurable cs
where
unconfigurable =
[ (pkg, missing) -- if necessary we could look up missing reasons
| (Just pkg', pkg) <- zip (map getSourcePkg pkgs) pkgs
, Left missing <- [configure cs pkg'] ]
addExcludeConstraint (pkg, missing) rest cs =
let reason = ExcludedByConfigureFail missing in
case addPackageExcludeConstraint (packageId pkg) reason cs of
Satisfiable cs' [pkgid]| packageId pkg == pkgid
-> Step (ExcludeUnconfigurable pkgid) (rest cs')
Satisfiable _ _ -> impossible "pruneBottomUp satisfiable"
_ -> Fail $ ConfigureFailed pkg
[ (dep, Constraints.conflicting cs dep)
| dep <- missing ]
configure cs (UnconfiguredPackage (SourcePackage _ pkg _ _) _ flags stanzas) =
finalizePackageDescription flags (dependencySatisfiable cs)
platform comp [] (enableStanzas stanzas pkg)
dependencySatisfiable cs =
not . null . PackageIndex.lookupDependency (Constraints.choices cs)
-- collect each group of packages (by name) in reverse topsort order
initialPackages =
reverse
. sortBy (comparing (topSortNumber . head))
. PackageIndex.allPackagesByName
. Constraints.choices
topSortNumber (InstalledOnly (InstalledPackageEx _ i _)) = i
topSortNumber (SourceOnly (UnconfiguredPackage _ i _ _)) = i
topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _ _)) = i
getSourcePkg (InstalledOnly _ ) = Nothing
getSourcePkg (SourceOnly spkg) = Just spkg
getSourcePkg (InstalledAndSource _ spkg) = Just spkg
configurePackage :: Platform -> CompilerId -> ConfigurePackage
configurePackage platform comp available spkg = case spkg of
InstalledOnly ipkg -> Right (InstalledOnly ipkg)
SourceOnly apkg -> fmap SourceOnly (configure apkg)
InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg)
(configure apkg)
where
configure (UnconfiguredPackage apkg@(SourcePackage _ p _ _) _ flags stanzas) =
case finalizePackageDescription flags dependencySatisfiable
platform comp [] (enableStanzas stanzas p) of
Left missing -> Left missing
Right (pkg, flags') -> Right $
SemiConfiguredPackage apkg flags' stanzas (externalBuildDepends pkg)
dependencySatisfiable = not . null . PackageIndex.lookupDependency available
-- | Annotate each installed packages with its set of transative dependencies
-- and its topological sort number.
--
annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)
-> PackageIndex InstalledPackage
-> PackageIndex InstalledPackageEx
annotateInstalledPackages dfsNumber installed = PackageIndex.fromList
[ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)
| pkg <- PackageIndex.allPackages installed ]
where
transitiveDepends :: InstalledPackage -> [PackageId]
transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph
. fromJust . toVertex . packageId
(graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed
-- | Annotate each available packages with its topological sort number and any
-- user-supplied partial flag assignment.
--
annotateSourcePackages :: [PackageConstraint]
-> (PackageName -> TopologicalSortNumber)
-> PackageIndex SourcePackage
-> PackageIndex UnconfiguredPackage
annotateSourcePackages constraints dfsNumber sourcePkgIndex =
PackageIndex.fromList
[ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) (stanzasFor name)
| pkg <- PackageIndex.allPackages sourcePkgIndex
, let name = packageName pkg ]
where
flagsFor = fromMaybe [] . flip Map.lookup flagsMap
flagsMap = Map.fromList
[ (name, flags)
| PackageConstraintFlags name flags <- constraints ]
stanzasFor = fromMaybe [] . flip Map.lookup stanzasMap
stanzasMap = Map.fromListWith (++)
[ (name, stanzas)
| PackageConstraintStanzas name stanzas <- constraints ]
-- | One of the heuristics we use when guessing which path to take in the
-- search space is an ordering on the choices we make. It's generally better
-- to make decisions about packages higer in the dep graph first since they
-- place constraints on packages lower in the dep graph.
--
-- To pick them in that order we annotate each package with its topological
-- sort number. So if package A depends on package B then package A will have
-- a lower topological sort number than B and we'll make a choice about which
-- version of A to pick before we make a choice about B (unless there is only
-- one possible choice for B in which case we pick that immediately).
--
-- To construct these topological sort numbers we combine and flatten the
-- installed and source package sets. We consider only dependencies between
-- named packages, not including versions and for not-yet-configured packages
-- we look at all the possible dependencies, not just those under any single
-- flag assignment. This means we can actually get impossible combinations of
-- edges and even cycles, but that doesn't really matter here, it's only a
-- heuristic.
--
topologicalSortNumbering :: PackageIndex InstalledPackage
-> PackageIndex SourcePackage
-> (PackageName -> TopologicalSortNumber)
topologicalSortNumbering installedPkgIndex sourcePkgIndex =
\pkgname -> let Just vertex = toVertex pkgname
in topologicalSortNumbers Array.! vertex
where
topologicalSortNumbers = Array.array (Array.bounds graph)
(zip (Graph.topSort graph) [0..])
(graph, _, toVertex) = Graph.graphFromEdges $
[ ((), packageName pkg, nub deps)
| pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex
, let deps = [ packageName dep
| pkg' <- pkgs
, dep <- depends pkg' ] ]
++ [ ((), packageName pkg, nub deps)
| pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex
, let deps = [ depName
| SourcePackage _ pkg' _ _ <- pkgs
, Dependency depName _ <-
buildDepends (flattenPackageDescription pkg') ] ]
-- | We don't need the entire index (which is rather large and costly if we
-- force it by examining the whole thing). So trace out the maximul subset of
-- each index that we could possibly ever need. Do this by flattening packages
-- and looking at the names of all possible dependencies.
--
selectNeededSubset :: PackageIndex InstalledPackage
-> PackageIndex SourcePackage
-> Set PackageName
-> (PackageIndex InstalledPackage
,PackageIndex SourcePackage)
selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty
where
select :: PackageIndex InstalledPackage
-> PackageIndex SourcePackage
-> Set PackageName
-> (PackageIndex InstalledPackage
,PackageIndex SourcePackage)
select installedPkgIndex' sourcePkgIndex' remaining
| Set.null remaining = (installedPkgIndex', sourcePkgIndex')
| otherwise = select installedPkgIndex'' sourcePkgIndex'' remaining''
where
(next, remaining') = Set.deleteFindMin remaining
moreInstalled = PackageIndex.lookupPackageName installedPkgIndex next
moreSource = PackageIndex.lookupPackageName sourcePkgIndex next
moreRemaining = -- we filter out packages already included in the indexes
-- this avoids an infinite loop if a package depends on itself
-- like base-3.0.3.0 with base-4.0.0.0
filter notAlreadyIncluded
$ [ packageName dep
| pkg <- moreInstalled
, dep <- depends pkg ]
++ [ name
| SourcePackage _ pkg _ _ <- moreSource
, Dependency name _ <-
buildDepends (flattenPackageDescription pkg) ]
installedPkgIndex'' = foldl' (flip PackageIndex.insert)
installedPkgIndex' moreInstalled
sourcePkgIndex'' = foldl' (flip PackageIndex.insert)
sourcePkgIndex' moreSource
remaining'' = foldl' (flip Set.insert)
remaining' moreRemaining
notAlreadyIncluded name =
null (PackageIndex.lookupPackageName installedPkgIndex' name)
&& null (PackageIndex.lookupPackageName sourcePkgIndex' name)
-- ------------------------------------------------------------
-- * Post processing the solution
-- ------------------------------------------------------------
finaliseSelectedPackages :: (PackageName -> PackagePreferences)
-> SelectedPackages
-> Constraints
-> [PlanPackage]
finaliseSelectedPackages pref selected constraints =
map finaliseSelected (PackageIndex.allPackages selected)
where
remainingChoices = Constraints.choices constraints
finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg
finaliseSelected (SourceOnly apkg) = finaliseSource Nothing apkg
finaliseSelected (InstalledAndSource ipkg apkg) =
case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of
--picked package not in constraints
Nothing -> impossible "finaliseSelected no pkg"
-- to constrain to avail only:
Just (SourceOnly _) -> impossible "finaliseSelected src only"
Just (InstalledOnly _) -> finaliseInstalled ipkg
Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg
finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg
finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) =
InstallPlan.Configured (ConfiguredPackage pkg flags stanzas deps')
where
deps' = map (packageId . pickRemaining mipkg) deps
pickRemaining mipkg dep@(Dependency _name versionRange) =
case PackageIndex.lookupDependency remainingChoices dep of
[] -> impossible "pickRemaining no pkg"
[pkg'] -> pkg'
remaining -> assert (checkIsPaired remaining)
$ maximumBy bestByPref remaining
where
-- We order candidate packages to pick for a dependency by these
-- three factors. The last factor is just highest version wins.
bestByPref =
comparing (\p -> (isCurrent p, isPreferred p, packageVersion p))
-- Is the package already used by the installed version of this
-- package? If so we should pick that first. This stops us from doing
-- silly things like deciding to rebuild haskell98 against base 3.
isCurrent = case mipkg :: Maybe InstalledPackageEx of
Nothing -> \_ -> False
Just ipkg -> \p -> packageId p `elem` depends ipkg
-- If there is no upper bound on the version range then we apply a
-- preferred version according to the hackage or user's suggested
-- version constraints. TODO: distinguish hacks from prefs
bounded = boundedAbove versionRange
isPreferred p
| bounded = True -- any constant will do
| otherwise = packageVersion p `withinRange` preferredVersions
where (PackagePreferences preferredVersions _) = pref (packageName p)
boundedAbove :: VersionRange -> Bool
boundedAbove vr = case asVersionIntervals vr of
[] -> True -- this is the inconsistent version range.
intervals -> case last intervals of
(_, UpperBound _ _) -> True
(_, NoUpperBound ) -> False
-- We really only expect to find more than one choice remaining when
-- we're finalising a dependency on a paired package.
checkIsPaired [p1, p2] =
case Constraints.isPaired constraints (packageId p1) of
Just p2' -> packageId p2' == packageId p2
Nothing -> False
checkIsPaired _ = False
-- | Improve an existing installation plan by, where possible, swapping
-- packages we plan to install with ones that are already installed.
-- This may add additional constraints due to the dependencies of installed
-- packages on other installed packages.
--
improvePlan :: PackageIndex InstalledPackage
-> Constraints
-> PackageIndex PlanPackage
-> (PackageIndex PlanPackage, Constraints)
improvePlan installed constraints0 selected0 =
foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)
where
improve (selected, constraints) = fromMaybe (selected, constraints)
. improvePkg selected constraints
-- The idea is to improve the plan by swapping a configured package for
-- an equivalent installed one. For a particular package the condition is
-- that the package be in a configured state, that a the same version be
-- already installed with the exact same dependencies and all the packages
-- in the plan that it depends on are in the installed state
improvePkg selected constraints pkgid = do
Configured pkg <- PackageIndex.lookupPackageId selected pkgid
ipkg <- PackageIndex.lookupPackageId installed pkgid
guard $ all (isInstalled selected) (depends pkg)
tryInstalled selected constraints [ipkg]
isInstalled selected pkgid =
case PackageIndex.lookupPackageId selected pkgid of
Just (PreExisting _) -> True
_ -> False
tryInstalled :: PackageIndex PlanPackage -> Constraints
-> [InstalledPackage]
-> Maybe (PackageIndex PlanPackage, Constraints)
tryInstalled selected constraints [] = Just (selected, constraints)
tryInstalled selected constraints (pkg:pkgs) =
case constraintsOk (packageId pkg) (depends pkg) constraints of
Nothing -> Nothing
Just constraints' -> tryInstalled selected' constraints' pkgs'
where
selected' = PackageIndex.insert (PreExisting pkg) selected
pkgs' = catMaybes (map notSelected (depends pkg)) ++ pkgs
notSelected pkgid =
case (PackageIndex.lookupPackageId installed pkgid
,PackageIndex.lookupPackageId selected pkgid) of
(Just pkg', Nothing) -> Just pkg'
_ -> Nothing
constraintsOk _ [] constraints = Just constraints
constraintsOk pkgid (pkgid':pkgids) constraints =
case addPackageDependencyConstraint pkgid dep True constraints of
Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'
_ -> Nothing
where
dep = thisPackageVersion pkgid'
reverseTopologicalOrder :: PackageFixedDeps pkg
=> PackageIndex pkg -> [PackageId]
reverseTopologicalOrder index = map (packageId . toPkg)
. Graph.topSort
. Graph.transposeG
$ graph
where (graph, toPkg, _) = PackageIndex.dependencyGraph index
-- ------------------------------------------------------------
-- * Adding and recording constraints
-- ------------------------------------------------------------
addPackageSelectConstraint :: PackageId -> Constraints
-> Satisfiable Constraints
[PackageId] ExclusionReason
addPackageSelectConstraint pkgid =
Constraints.constrain pkgname constraint reason
where
pkgname = packageName pkgid
constraint ver _ = ver == packageVersion pkgid
reason = SelectedOther pkgid
addPackageExcludeConstraint :: PackageId -> ExclusionReason
-> Constraints
-> Satisfiable Constraints
[PackageId] ExclusionReason
addPackageExcludeConstraint pkgid reason =
Constraints.constrain pkgname constraint reason
where
pkgname = packageName pkgid
constraint ver installed
| ver == packageVersion pkgid = installed
| otherwise = True
addPackageDependencyConstraint :: PackageId -> Dependency -> Bool
-> Constraints
-> Satisfiable Constraints
[PackageId] ExclusionReason
addPackageDependencyConstraint pkgid dep@(Dependency pkgname verrange)
installedConstraint =
Constraints.constrain pkgname constraint reason
where
constraint ver installed = ver `withinRange` verrange
&& if installedConstraint then installed else True
reason = ExcludedByPackageDependency pkgid dep installedConstraint
addTopLevelVersionConstraint :: PackageName -> VersionRange
-> Constraints
-> Satisfiable Constraints
[PackageId] ExclusionReason
addTopLevelVersionConstraint pkgname verrange =
Constraints.constrain pkgname constraint reason
where
constraint ver _installed = ver `withinRange` verrange
reason = ExcludedByTopLevelConstraintVersion pkgname verrange
addTopLevelInstalledConstraint,
addTopLevelSourceConstraint :: PackageName
-> Constraints
-> Satisfiable Constraints
[PackageId] ExclusionReason
addTopLevelInstalledConstraint pkgname =
Constraints.constrain pkgname constraint reason
where
constraint _ver installed = installed
reason = ExcludedByTopLevelConstraintInstalled pkgname
addTopLevelSourceConstraint pkgname =
Constraints.constrain pkgname constraint reason
where
constraint _ver installed = not installed
reason = ExcludedByTopLevelConstraintSource pkgname
-- ------------------------------------------------------------
-- * Reasons for constraints
-- ------------------------------------------------------------
-- | For every constraint we record we also record the reason that constraint
-- is needed. So if we end up failing due to conflicting constraints then we
-- can give an explnanation as to what was conflicting and why.
--
data ExclusionReason =
-- | We selected this other version of the package. That means we exclude
-- all the other versions.
SelectedOther PackageId
-- | We excluded this version of the package because it failed to
-- configure probably because of unsatisfiable deps.
| ExcludedByConfigureFail [Dependency]
-- | We excluded this version of the package because another package that
-- we selected imposed a dependency which this package did not satisfy.
| ExcludedByPackageDependency PackageId Dependency Bool
-- | We excluded this version of the package because it did not satisfy
-- a dependency given as an original top level input.
--
| ExcludedByTopLevelConstraintVersion PackageName VersionRange
| ExcludedByTopLevelConstraintInstalled PackageName
| ExcludedByTopLevelConstraintSource PackageName
deriving Eq
-- | Given an excluded package and the reason it was excluded, produce a human
-- readable explanation.
--
showExclusionReason :: PackageId -> ExclusionReason -> String
showExclusionReason pkgid (SelectedOther pkgid') =
display pkgid ++ " was excluded because " ++
display pkgid' ++ " was selected instead"
showExclusionReason pkgid (ExcludedByConfigureFail missingDeps) =
display pkgid ++ " was excluded because it could not be configured. "
++ "It requires " ++ listOf displayDep missingDeps
showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep installedConstraint)
= display pkgid ++ " was excluded because " ++ display pkgid' ++ " requires "
++ (if installedConstraint then "an installed instance of " else "")
++ displayDep dep
showExclusionReason pkgid (ExcludedByTopLevelConstraintVersion pkgname verRange) =
display pkgid ++ " was excluded because of the top level constraint " ++
displayDep (Dependency pkgname verRange)
showExclusionReason pkgid (ExcludedByTopLevelConstraintInstalled pkgname)
= display pkgid ++ " was excluded because of the top level constraint '"
++ display pkgname ++ " installed' which means that only installed instances "
++ "of the package may be selected."
showExclusionReason pkgid (ExcludedByTopLevelConstraintSource pkgname)
= display pkgid ++ " was excluded because of the top level constraint '"
++ display pkgname ++ " source' which means that only source versions "
++ "of the package may be selected."
-- ------------------------------------------------------------
-- * Logging progress and failures
-- ------------------------------------------------------------
data Log = Select [SelectedPackage] [PackageId]
| AppliedVersionConstraint PackageName VersionRange [PackageId]
| AppliedInstalledConstraint PackageName InstalledConstraint [PackageId]
| ExcludeUnconfigurable PackageId
data Failure
= NoSuchPackage
PackageName
| ConfigureFailed
SelectablePackage
[(Dependency, [(PackageId, [ExclusionReason])])]
| DependencyConflict
SelectedPackage Dependency Bool
[(PackageId, [ExclusionReason])]
| TopLevelVersionConstraintConflict
PackageName VersionRange
[(PackageId, [ExclusionReason])]
| TopLevelVersionConstraintUnsatisfiable
PackageName VersionRange
| TopLevelInstallConstraintConflict
PackageName InstalledConstraint
[(PackageId, [ExclusionReason])]
| TopLevelInstallConstraintUnsatisfiable
PackageName InstalledConstraint
showLog :: Log -> String
showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of
("", y) -> y
(x, "") -> x
(x, y) -> x ++ " and " ++ y
where
selectedMsg = "selecting " ++ case selected of
[] -> ""
[s] -> display (packageId s) ++ " " ++ kind s
(s:ss) -> listOf id
$ (display (packageId s) ++ " " ++ kind s)
: [ display (packageVersion s') ++ " " ++ kind s'
| s' <- ss ]
kind (InstalledOnly _) = "(installed)"
kind (SourceOnly _) = "(source)"
kind (InstalledAndSource _ _) = "(installed or source)"
discardedMsg = case discarded of
[] -> ""
_ -> "discarding " ++ listOf id
[ element
| (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded)
, element <- display pkgid : map (display . packageVersion) pkgids ]
showLog (AppliedVersionConstraint pkgname ver pkgids) =
"applying constraint " ++ display (Dependency pkgname ver)
++ if null pkgids
then ""
else "which excludes " ++ listOf display pkgids
showLog (AppliedInstalledConstraint pkgname inst pkgids) =
"applying constraint " ++ display pkgname ++ " '"
++ (case inst of InstalledConstraint -> "installed"; _ -> "source") ++ "' "
++ if null pkgids
then ""
else "which excludes " ++ listOf display pkgids
showLog (ExcludeUnconfigurable pkgid) =
"excluding " ++ display pkgid ++ " (it cannot be configured)"
showFailure :: Failure -> String
showFailure (NoSuchPackage pkgname) =
"The package " ++ display pkgname ++ " is unknown."
showFailure (ConfigureFailed pkg missingDeps) =
"cannot configure " ++ displayPkg pkg ++ ". It requires "
++ listOf (displayDep . fst) missingDeps
++ '\n' : unlines (map (uncurry whyNot) missingDeps)
where
whyNot (Dependency name ver) [] =
"There is no available version of " ++ display name
++ " that satisfies " ++ displayVer ver
whyNot dep conflicts =
"For the dependency on " ++ displayDep dep
++ " there are these packages: " ++ listOf display pkgs
++ ". However none of them are available.\n"
++ unlines [ showExclusionReason (packageId pkg') reason
| (pkg', reasons) <- conflicts, reason <- reasons ]
where pkgs = map fst conflicts
showFailure (DependencyConflict pkg dep installedConstraint conflicts) =
"dependencies conflict: "
++ displayPkg pkg ++ " requires "
++ (if installedConstraint then "an installed instance of " else "")
++ displayDep dep ++ " however:\n"
++ unlines [ showExclusionReason (packageId pkg') reason
| (pkg', reasons) <- conflicts, reason <- reasons ]
showFailure (TopLevelVersionConstraintConflict name ver conflicts) =
"constraints conflict: we have the top level constraint "
++ displayDep (Dependency name ver) ++ ", but\n"
++ unlines [ showExclusionReason (packageId pkg') reason
| (pkg', reasons) <- conflicts, reason <- reasons ]
showFailure (TopLevelVersionConstraintUnsatisfiable name ver) =
"There is no available version of " ++ display name
++ " that satisfies " ++ displayVer ver
showFailure (TopLevelInstallConstraintConflict name InstalledConstraint conflicts) =
"constraints conflict: "
++ "top level constraint '" ++ display name ++ " installed' however\n"
++ unlines [ showExclusionReason (packageId pkg') reason
| (pkg', reasons) <- conflicts, reason <- reasons ]
showFailure (TopLevelInstallConstraintUnsatisfiable name InstalledConstraint) =
"There is no installed version of " ++ display name
showFailure (TopLevelInstallConstraintConflict name SourceConstraint conflicts) =
"constraints conflict: "
++ "top level constraint '" ++ display name ++ " source' however\n"
++ unlines [ showExclusionReason (packageId pkg') reason
| (pkg', reasons) <- conflicts, reason <- reasons ]
showFailure (TopLevelInstallConstraintUnsatisfiable name SourceConstraint) =
"There is no available source version of " ++ display name
displayVer :: VersionRange -> String
displayVer = display . simplifyVersionRange
displayDep :: Dependency -> String
displayDep = display . simplifyDependency
-- ------------------------------------------------------------
-- * Utils
-- ------------------------------------------------------------
impossible :: String -> a
impossible msg = internalError $ "assertion failure: " ++ msg
internalError :: String -> a
internalError msg = error $ "internal error: " ++ msg
displayPkg :: Package pkg => pkg -> String
displayPkg = display . packageId
listOf :: (a -> String) -> [a] -> String
listOf _ [] = []
listOf disp [x0] = disp x0
listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs
where go x [] = " and " ++ disp x
go x (x':xs') = ", " ++ disp x ++ go x' xs'