Commit bc07102a authored by Duncan Coutts's avatar Duncan Coutts
Browse files

First version of the top-down package dependency resolver

This is a new dependency resolver that produces valid install plans.
It works in polynomial time however because the search space is 
exponential in size it is not guaranteed to find a solution even if
one exists. It works by generating and then exploring the search
space represented as a lazy tree. It uses constraints to prune
choices and heuristics when guesses are necessary. Currently it can
generate install plans for 99% of the packages on hackage. The
remaining 6 packages should be doable with two extra tricks.
It is not finished and is not yet usable in practice.
parent b2e5c1f9
......@@ -18,6 +18,7 @@ module Hackage.Dependency
import Hackage.Dependency.Naive (naiveResolver)
import Hackage.Dependency.Bogus (bogusResolver)
import Hackage.Dependency.TopDown (topDownResolver)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
......@@ -45,6 +46,7 @@ import Control.Exception (assert)
defaultResolver :: DependencyResolver a
defaultResolver = naiveResolver
--for the brave: try the new topDownResolver, but only with --dry-run !!!
resolveDependencies :: OS
-> Arch
......
-----------------------------------------------------------------------------
-- |
-- Module : Hackage.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 Hackage.Dependency.TopDown (
topDownResolver
) where
import Hackage.Dependency.TopDown.Types
import qualified Hackage.Dependency.TopDown.Constraints as Constraints
import Hackage.Dependency.TopDown.Constraints
( Satisfiable(..) )
import qualified Hackage.InstallPlan as InstallPlan
import Hackage.Types
( UnresolvedDependency(..), AvailablePackage(..)
, ConfiguredPackage(..) )
import Hackage.Dependency.Types
( DependencyResolver, Progress )
import qualified Hackage.Dependency.Types as Progress
( Progress(..), foldProgress )
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import Distribution.Package
( PackageIdentifier(PackageIdentifier), Dependency(Dependency)
, Package(..), packageVersion )
import Distribution.PackageDescription
( PackageDescription(buildDepends) )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription)
import Distribution.Version
( VersionRange(..) )
import Distribution.Compiler
( CompilerId )
import Distribution.System
( OS, Arch )
import Distribution.Simple.Utils
( equating, comparing )
import Distribution.Text
( display )
import Data.List
( maximumBy, deleteBy )
import Data.Maybe
( fromJust )
import Data.Monoid
( Monoid(mempty) )
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Graph as Graph
import Debug.Trace (trace)
-- ------------------------------------------------------------
-- * Search state types
-- ------------------------------------------------------------
type Constraints = Constraints.Constraints
InstalledPackage AvailablePackage 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 :: SearchSpace a SelectablePackage
-> Progress Log Failure a
explore (Failure failure) = Progress.Fail failure
explore (ChoiceNode result []) = Progress.Done result
explore (ChoiceNode _ (choices@(defaultChoice:_))) =
case [ choice | [choice] <- choices ] of
((pkg, node'):_) -> Progress.Step (Select pkg []) (explore node')
[] -> seq pkgs' -- avoid retaining defaultChoice
$ Progress.Step (Select pkg pkgs') (explore node')
where
(pkg, node') = maximumBy (comparing (packageId . fst)) defaultChoice
pkgs' = deleteBy (equating packageId) pkg (map fst defaultChoice)
-- ------------------------------------------------------------
-- * Generate a search tree
-- ------------------------------------------------------------
type ConfigurePackage = PackageIndex SelectablePackage
-> SelectablePackage
-> Either [Dependency] SelectedPackage
searchSpace :: ConfigurePackage
-> Constraints
-> SelectedPackages
-> Set PackageName
-> SearchSpace (SelectedPackages, Constraints) SelectablePackage
searchSpace configure constraints selected next =
ChoiceNode (selected, constraints)
[ [ (pkg, select name pkg)
| pkg <- PackageIndex.lookupPackageName available name ]
| name <- Set.elems next ]
where
available = Constraints.choices constraints
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' (packageConstraints pkg') constraints of
Left failure -> Failure failure
Right constraints' -> searchSpace configure constraints'' selected' next'
where
selected' = PackageIndex.insert pkg' selected
next' = Set.delete name $ foldr Set.insert next new
new = [ name'
| dep <- packageConstraints pkg'
, let (Dependency name' _) = untagDependency dep
, null (PackageIndex.lookupPackageName selected' name') ]
Satisfiable constraints'' = addPackageSelectConstraint (packageId pkg) constraints'
packageConstraints :: SelectedPackage -> [TaggedDependency]
packageConstraints = either installedConstraints availableConstraints
. preferAvailable
where
preferAvailable (InstalledOnly pkg) = Left pkg
preferAvailable (AvailableOnly pkg) = Right pkg
preferAvailable (InstalledAndAvailable _ pkg) = Right pkg
installedConstraints (InstalledPackage _ deps) =
[ TaggedDependency InstalledConstraint (thisPackageVersion dep)
| dep <- deps ]
availableConstraints (SemiConfiguredPackage _ _ deps) =
[ TaggedDependency NoInstalledConstraint dep | dep <- deps ]
constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints
-> Either Failure Constraints
constrainDeps _ [] cs = Right cs
constrainDeps pkg (dep:deps) cs =
case addPackageDependencyConstraint (packageId pkg) dep cs of
Satisfiable cs' -> constrainDeps pkg deps cs'
Unsatisfiable -> impossible
ConflictsWith conflicts ->
Left (DependencyConflict pkg dep conflicts)
-- ------------------------------------------------------------
-- * The main algorithm
-- ------------------------------------------------------------
search :: ConfigurePackage
-> Constraints
-> Set PackageName
-> Progress Log Failure (SelectedPackages, Constraints)
search configure constraints =
explore . 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 a
topDownResolver = (((((mapMessages .).).).).) . topDownResolver'
where
mapMessages :: Progress Log Failure a -> Either [Dependency] a
mapMessages = Progress.foldProgress (trace . showLog)
(error . showFailure)
Right
-- | The native resolver with detailed structured logging and failure types.
--
topDownResolver' :: OS -> Arch -> CompilerId
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
-> [UnresolvedDependency]
-> Progress Log Failure [InstallPlan.PlanPackage a]
topDownResolver' os arch comp installed available deps =
fmap (uncurry finaliseSelectedPackages)
$ search (configurePackage os arch comp) constraints initialPkgNames
where
--TODO add actual constraints using addTopLevelDependencyConstraint
constraints = Constraints.empty installed' available
installed' = PackageIndex.fromList
[ InstalledPackage pkg (transitiveDepends pkg)
| pkg <- PackageIndex.allPackages installed ]
transitiveDepends :: InstalledPackageInfo -> [PackageIdentifier]
transitiveDepends = map toPkgid . tail . Graph.reachable graph
. fromJust . toVertex . packageId
(graph, toPkgid, toVertex) = PackageIndex.dependencyGraph installed
initialDeps = [ dep | UnresolvedDependency dep _ <- deps ]
initialPkgNames = Set.fromList [ name | Dependency name _ <- initialDeps ]
configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage
configurePackage os arch comp available spkg = case spkg of
InstalledOnly ipkg -> Right (InstalledOnly ipkg)
AvailableOnly apkg -> fmap AvailableOnly (configure apkg)
InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)
(configure apkg)
where
configure apkg@(AvailablePackage _ p _) =
case finalizePackageDescription [] (Just available) os arch comp [] p of
Left missing -> Left missing
Right (pkg, flags) -> Right $
SemiConfiguredPackage apkg flags (buildDepends pkg)
finaliseSelectedPackages :: SelectedPackages
-> Constraints
-> [InstallPlan.PlanPackage a]
finaliseSelectedPackages selected constraints =
map finaliseSelected (PackageIndex.allPackages selected)
where
remainingChoices = Constraints.choices constraints
finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg
finaliseSelected (AvailableOnly apkg) = finaliseAvailable apkg
finaliseSelected (InstalledAndAvailable ipkg apkg) =
case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of
Nothing -> impossible --picked package not in constraints
Just (AvailableOnly _) -> impossible --to constrain to avail only
Just (InstalledOnly _) -> finaliseInstalled ipkg
Just (InstalledAndAvailable _ _) -> finaliseAvailable apkg
--TODO: improve the plan by picking installed packages where possible
finaliseInstalled (InstalledPackage pkg _) = InstallPlan.PreExisting pkg
finaliseAvailable (SemiConfiguredPackage pkg flags deps) =
InstallPlan.Configured (ConfiguredPackage pkg flags deps')
where deps' = [ packageId pkg'
| dep <- deps
, let pkg' = case PackageIndex.lookupDependency selected dep of
[pkg''] -> pkg''
_ -> impossible ]
-- ------------------------------------------------------------
-- * Adding and recording constraints
-- ------------------------------------------------------------
addPackageSelectConstraint :: PackageIdentifier -> Constraints
-> Satisfiable Constraints ExclusionReason
addPackageSelectConstraint pkgid constraints =
Constraints.constrain dep reason constraints
where
dep = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)
reason = SelectedOther pkgid
thisPackageVersion :: PackageIdentifier -> Dependency
thisPackageVersion (PackageIdentifier n v) = Dependency n (ThisVersion v)
addPackageExcludeConstraint :: PackageIdentifier -> Constraints
-> Satisfiable Constraints ExclusionReason
addPackageExcludeConstraint pkgid constraints =
Constraints.constrain dep reason constraints
where
dep = TaggedDependency NoInstalledConstraint
(notThisPackageVersion pkgid)
reason = ExcludedByConfigureFail
notThisPackageVersion (PackageIdentifier n v) =
Dependency n (notThisVersion v)
notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v)
addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints
-> Satisfiable Constraints ExclusionReason
addPackageDependencyConstraint pkgid dep constraints =
Constraints.constrain dep reason constraints
where
reason = ExcludedByPackageDependency pkgid dep
addTopLevelDependencyConstraint :: Dependency -> Constraints
-> Satisfiable Constraints ExclusionReason
addTopLevelDependencyConstraint dep constraints =
Constraints.constrain taggedDep reason constraints
where
taggedDep = TaggedDependency NoInstalledConstraint dep
reason = ExcludedByTopLevelDependency dep
-- ------------------------------------------------------------
-- * 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 PackageIdentifier
-- | We excluded this version of the package because it failed to
-- configure probably because of unsatisfiable deps.
| ExcludedByConfigureFail
-- | We excluded this version of the package because another package that
-- we selected imposed a dependency which this package did not satisfy.
| ExcludedByPackageDependency PackageIdentifier TaggedDependency
-- | We excluded this version of the package because it did not satisfy
-- a dependency given as an original top level input.
--
| ExcludedByTopLevelDependency Dependency
-- | Given an excluded package and the reason it was excluded, produce a human
-- readable explanation.
--
showExclusionReason :: PackageIdentifier -> ExclusionReason -> String
showExclusionReason pkgid (SelectedOther pkgid') =
display pkgid ++ " was excluded because " ++
display pkgid' ++ " was selected instead"
showExclusionReason pkgid ExcludedByConfigureFail =
display pkgid ++ " was excluded because it could not be configured"
showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) =
display pkgid ++ " was excluded because " ++
display pkgid' ++ " requires " ++ display (untagDependency dep)
-- ------------------------------------------------------------
-- * Logging progress and failures
-- ------------------------------------------------------------
data Log = Select SelectablePackage [SelectablePackage]
data Failure
= ConfigureFailed
SelectablePackage
[(Dependency, [(PackageIdentifier, [ExclusionReason])])]
| DependencyConflict
SelectedPackage TaggedDependency
[(PackageIdentifier, [ExclusionReason])]
showLog :: Log -> String
showLog (Select selected discarded) =
"selecting " ++ displayPkg selected ++ " " ++ kind selected
++ case discarded of
[] -> ""
[d] -> " and discarding version " ++ display (packageVersion d)
_ -> " and discarding versions "
++ listOf (display . packageVersion) discarded
where
kind (InstalledOnly _) = "(installed)"
kind (AvailableOnly _) = "(hackage)"
kind (InstalledAndAvailable _ _) = "(installed or hackage)"
showFailure :: Failure -> String
showFailure (ConfigureFailed pkg missingDeps) =
"cannot configure " ++ displayPkg pkg ++ ". It requires "
++ listOf (display . fst) missingDeps
++ '\n' : unlines (map (uncurry whyNot) missingDeps)
where
whyNot (Dependency name ver) [] =
"There is no available version of " ++ name
++ " that satisfies " ++ display ver
whyNot dep conflicts =
"For the dependency on " ++ display 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 (TaggedDependency _ dep) conflicts) =
"dependencies conflict: "
++ displayPkg pkg ++ " requires " ++ display dep ++ " however\n"
++ unlines [ showExclusionReason (packageId pkg') reason
| (pkg', reasons) <- conflicts, reason <- reasons ]
-- ------------------------------------------------------------
-- * Utils
-- ------------------------------------------------------------
impossible :: a
impossible = internalError "impossible"
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'
-----------------------------------------------------------------------------
-- |
-- Module : Hackage.Dependency.TopDown.Constraints
-- Copyright : (c) Duncan Coutts 2008
-- License : BSD-like
--
-- Maintainer : duncan@haskell.org
-- Stability : provisional
-- Portability : portable
--
-- A set of satisfiable dependencies (package version constraints).
-----------------------------------------------------------------------------
module Hackage.Dependency.TopDown.Constraints (
Constraints,
empty,
choices,
constrain,
Satisfiable(..),
conflicting,
) where
import Hackage.Dependency.TopDown.Types
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Package
( PackageIdentifier(..), Package(..), packageVersion, packageName
, Dependency(..) )
import Distribution.Version
( withinRange )
import Distribution.Simple.Utils
( comparing )
import Hackage.Utils
( mergeBy, MergeResult(..) )
import Data.List
( foldl', sortBy )
import Data.Monoid
( Monoid(mempty) )
import Control.Exception
( assert )
-- | A set of constraints on package versions. For each package name we record
-- what other packages depends on it and what constraints they impose on the
-- version of the package.
--
data (Package installed, Package available)
=> Constraints installed available reason
= Constraints
-- | Remaining available choices
(PackageIndex (InstalledOrAvailable installed available))
-- | Choices that we have excluded for some reason
-- usually by applying constraints
(PackageIndex (ExcludedPackage PackageIdentifier reason))
data ExcludedPackage pkg reason
= ExcludedPackage pkg [reason] -- reasons for excluding just the available
[reason] -- reasons for excluding installed and avail
instance Package pkg => Package (ExcludedPackage pkg reason) where
packageId (ExcludedPackage p _ _) = packageId p
-- | The intersection between the two indexes is empty
invariant :: (Package installed, Package available)
=> Constraints installed available a -> Bool
invariant (Constraints available excluded) =
all (uncurry ok) [ (a, e) | InBoth a e <- merged ]
where
merged = mergeBy (\a b -> packageId a `compare` packageId b)
(PackageIndex.allPackages available)
(PackageIndex.allPackages excluded)
ok (InstalledOnly _) (ExcludedPackage _ _ []) = True
ok _ _ = False
-- | An update to the constraints can move packages between the two piles
-- but not gain or loose packages.
transitionsTo :: (Package installed, Package available)
=> Constraints installed available a
-> Constraints installed available a -> Bool
transitionsTo constraints @(Constraints available excluded )
constraints'@(Constraints available' excluded') =
invariant constraints && invariant constraints'
&& null availableGained && null excludedLost
&& map packageId availableLost == map packageId excludedGained
where
availableLost = foldr lost [] availableChange where
lost (OnlyInLeft pkg) rest = pkg : rest
lost (InBoth (InstalledAndAvailable _ pkg)
(InstalledOnly _)) rest = AvailableOnly pkg : rest
lost _ rest = rest
availableGained = [ pkg | OnlyInRight pkg <- availableChange ]
excludedLost = [ pkg | OnlyInLeft pkg <- excludedChange ]
excludedGained = [ pkg | OnlyInRight pkg <- excludedChange ]
availableChange = mergeBy (\a b -> packageId a `compare` packageId b)
(allPackagesInOrder available)
(allPackagesInOrder available')
excludedChange = mergeBy (\a b -> packageId a `compare` packageId b)
(allPackagesInOrder excluded)
(allPackagesInOrder excluded')
--FIXME: PackageIndex.allPackages returns in sorted order case-insensitively
-- but that's no good for our merge which uses Ord
allPackagesInOrder :: Package pkg => PackageIndex pkg -> [pkg]
allPackagesInOrder index =
concatMap snd
. sortBy (comparing fst)
$ [ (packageName pkg, grp)
| grp@(pkg:_) <- PackageIndex.allPackagesByName index ]
-- | We construct 'Constraints' with an initial 'PackageIndex' of all the
-- packages available.
--
empty :: (Package installed, Package available)
=> PackageIndex installed
-> PackageIndex available
-> Constraints installed available reason
empty installed available = Constraints pkgs mempty
where
pkgs = PackageIndex.fromList
. map toInstalledOrAvailable
$ mergeBy (\a b -> packageId a `compare` packageId b)
(allPackagesInOrder installed)
(allPackagesInOrder available)
toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i
toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a
toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a
-- | The package choices that are still available.
--
choices :: (Package installed, Package available)
=> Constraints installed available reason
-> PackageIndex (InstalledOrAvailable installed available)
choices (Constraints available _) = available
data Satisfiable a reason
= Satisfiable a
| Unsatisfiable
| ConflictsWith [(PackageIdentifier, [reason])]
constrain :: (Package installed, Package available)
=> TaggedDependency
-> reason
-> Constraints installed available reason
-> Satisfiable (Constraints installed available reason) reason
constrain (TaggedDependency installedConstraint (Dependency name versionRange))
reason constraints@(Constraints available excluded)
| not anyRemaining
= if null conflicts then Unsatisfiable
else ConflictsWith conflicts
| otherwise
= let constraints' = Constraints available' excluded'
in assert (constraints `transitionsTo` constraints') $
Satisfiable constraints'
where
-- This tells us if any packages would remain at all for this package name if
-- we applied this constraint. This amounts to checking if any package
-- satisfies the given constraint, including version range and installation
-- status.
--
anyRemaining = any satisfiesConstraint availableChoices
conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll)
| ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices
, satisfiesVersionConstraint pkg ]
-- Applying this constraint may involve deleting some choices for this
-- package name, or restricting which install states are available.
available' = updateAvailable available
updateAvailable = flip (foldl' (flip update)) availableChoices where
update pkg | not (satisfiesVersionConstraint pkg)
= PackageIndex.deletePackageId (packageId pkg)