From 3453175d9f88a4427b042930445ead6c06996493 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Sat, 28 Feb 2015 18:34:47 +0000
Subject: [PATCH] Make top-down solver more independent
Give the top-down solver it's own copy of `dependencyGraph`. This means that we
now have three independent implementations of `dependencyGraph`:
- `dependencyGraph` in `Cabal` takes a package index indexed by installed
package IDs and only has access to library dependencies.
- `dependencyGraph` in `Distribution.Client.PlanIndex` in `cabal-install` takes
a package index indexed by installed package IDs and has access to all
dependencies.
- `dependencyGraph` in the top-down solver in `cabal-install` takes a package
index indexed by package _names_, and has access to all dependencies.
Ideally we would switch the top-down solver over to use a package indexed by
installed package IDs, so that this duplication could be avoided, but that's a
bit of work and the top-down solver is legacy code anyway. Can still do that
later, of course.
Moreover, this makes the top-down solver monomorphic where possible, and
introduce its own SourceDeps class so that it is independent of the FixedDeps
class (which we will change over to use InstalledPackageIds instead).
---
.../Distribution/Client/Dependency/TopDown.hs | 68 +++++++++++++++----
.../Client/Dependency/TopDown/Constraints.hs | 14 ++--
.../Client/Dependency/TopDown/Types.hs | 48 +++++++++++--
3 files changed, 104 insertions(+), 26 deletions(-)
diff --git a/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal-install/Distribution/Client/Dependency/TopDown.hs
index f76943eb88..a4a083473e 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown.hs
@@ -33,9 +33,8 @@ import Distribution.Client.Dependency.Types
, Progress(..), foldProgress )
import qualified Distribution.Client.PackageIndex as PackageIndex
-import qualified Distribution.Client.PlanIndex as PlanIndex
import Distribution.Client.PackageIndex
- ( PackageIndex, PackageFixedDeps(depends) )
+ ( PackageIndex )
import Distribution.Package
( PackageName(..), PackageId, Package(..), packageVersion, packageName
, Dependency(Dependency), thisPackageVersion
@@ -425,7 +424,7 @@ annotateInstalledPackages dfsNumber installed = PackageIndex.fromList
transitiveDepends :: InstalledPackage -> [PackageId]
transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph
. fromJust . toVertex . packageId
- (graph, toPkg, toVertex) = PlanIndex.dependencyGraph installed
+ (graph, toPkg, toVertex) = dependencyGraph installed
-- | Annotate each available packages with its topological sort number and any
@@ -483,7 +482,7 @@ topologicalSortNumbering installedPkgIndex sourcePkgIndex =
| pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex
, let deps = [ packageName dep
| pkg' <- pkgs
- , dep <- depends pkg' ] ]
+ , dep <- sourceDeps pkg' ] ]
++ [ ((), packageName pkg, nub deps)
| pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex
, let deps = [ depName
@@ -521,7 +520,7 @@ selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty
filter notAlreadyIncluded
$ [ packageName dep
| pkg <- moreInstalled
- , dep <- depends pkg ]
+ , dep <- sourceDeps pkg ]
++ [ name
| SourcePackage _ pkg _ _ <- moreSource
, Dependency name _ <-
@@ -581,7 +580,7 @@ finaliseSelectedPackages pref selected constraints =
-- 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
+ Just ipkg -> \p -> packageId p `elem` sourceDeps 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
@@ -629,7 +628,7 @@ improvePlan installed constraints0 selected0 =
improvePkg selected constraints pkgid = do
Configured pkg <- PackageIndex.lookupPackageId selected pkgid
ipkg <- PackageIndex.lookupPackageId installed pkgid
- guard $ all (isInstalled selected) (depends pkg)
+ guard $ all (isInstalled selected) (sourceDeps pkg)
tryInstalled selected constraints [ipkg]
isInstalled selected pkgid =
@@ -642,12 +641,12 @@ improvePlan installed constraints0 selected0 =
-> Maybe (PackageIndex PlanPackage, Constraints)
tryInstalled selected constraints [] = Just (selected, constraints)
tryInstalled selected constraints (pkg:pkgs) =
- case constraintsOk (packageId pkg) (depends pkg) constraints of
+ case constraintsOk (packageId pkg) (sourceDeps 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
+ pkgs' = catMaybes (map notSelected (sourceDeps pkg)) ++ pkgs
notSelected pkgid =
case (PackageIndex.lookupPackageId installed pkgid
,PackageIndex.lookupPackageId selected pkgid) of
@@ -662,13 +661,12 @@ improvePlan installed constraints0 selected0 =
where
dep = thisPackageVersion pkgid'
- reverseTopologicalOrder :: PackageFixedDeps pkg
- => PackageIndex pkg -> [PackageId]
+ reverseTopologicalOrder :: PackageIndex PlanPackage -> [PackageId]
reverseTopologicalOrder index = map (packageId . toPkg)
. Graph.topSort
. Graph.transposeG
$ graph
- where (graph, toPkg, _) = PlanIndex.dependencyGraph index
+ where (graph, toPkg, _) = dependencyGraph index
-- ------------------------------------------------------------
-- * Adding and recording constraints
@@ -946,3 +944,49 @@ 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'
+
+-- ------------------------------------------------------------
+-- * Construct a dependency graph
+-- ------------------------------------------------------------
+
+-- | Builds a graph of the package dependencies.
+--
+-- Dependencies on other packages that are not in the index are discarded.
+-- You can check if there are any such dependencies with 'brokenPackages'.
+--
+-- The top-down solver gets its own implementation, because both
+-- `dependencyGraph` in `Distribution.Client.PlanIndex` (in cabal-install) and
+-- `dependencyGraph` in `Distribution.Simple.PackageIndex` (in Cabal) both work
+-- with `PackageIndex` from `Cabal` (that is, a package index indexed by
+-- installed package IDs rather than package names).
+--
+-- Ideally we would switch the top-down solver over to use that too, so that
+-- this duplication could be avoided, but that's a bit of work and the top-down
+-- solver is legacy code anyway.
+--
+-- (NOTE: This is called at two types: InstalledPackage and PlanPackage.)
+dependencyGraph :: PackageSourceDeps pkg
+ => PackageIndex pkg
+ -> (Graph.Graph,
+ Graph.Vertex -> pkg,
+ PackageId -> Maybe Graph.Vertex)
+dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex)
+ where
+ graph = Array.listArray bounds $
+ map (catMaybes . map pkgIdToVertex . sourceDeps) pkgs
+ vertexToPkg vertex = pkgTable Array.! vertex
+ pkgIdToVertex = binarySearch 0 topBound
+
+ pkgTable = Array.listArray bounds pkgs
+ pkgIdTable = Array.listArray bounds (map packageId pkgs)
+ pkgs = sortBy (comparing packageId) (PackageIndex.allPackages index)
+ topBound = length pkgs - 1
+ bounds = (0, topBound)
+
+ binarySearch a b key
+ | a > b = Nothing
+ | otherwise = case compare key (pkgIdTable Array.! mid) of
+ LT -> binarySearch a (mid-1) key
+ EQ -> Just mid
+ GT -> binarySearch (mid+1) b key
+ where mid = (a + b) `div` 2
diff --git a/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs b/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs
index 00004bcdcf..841dd539a3 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs
@@ -27,7 +27,7 @@ module Distribution.Client.Dependency.TopDown.Constraints (
import Distribution.Client.Dependency.TopDown.Types
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.PackageIndex
- ( PackageIndex, PackageFixedDeps(depends) )
+ ( PackageIndex )
import Distribution.Package
( PackageName, PackageId, PackageIdentifier(..)
, Package(packageId), packageName, packageVersion
@@ -225,14 +225,12 @@ transitionsTo constraints @(Constraints _ available excluded _ _)
SourceOnly b -> SourceOnly (g b)
InstalledAndSource a b -> InstalledAndSource (f a) (g b)
-
-- | We construct 'Constraints' with an initial 'PackageIndex' of all the
-- packages available.
--
-empty :: (PackageFixedDeps installed, Package source)
- => PackageIndex installed
- -> PackageIndex source
- -> Constraints installed source reason
+empty :: PackageIndex InstalledPackageEx
+ -> PackageIndex UnconfiguredPackage
+ -> Constraints InstalledPackageEx UnconfiguredPackage reason
empty installed source =
Constraints targets pkgs excluded pairs pkgs
where
@@ -254,8 +252,8 @@ empty installed source =
, let name = packageName pkg1
pkgid1 = packageId pkg1
pkgid2 = packageId pkg2
- , any ((pkgid1==) . packageId) (depends pkg2)
- || any ((pkgid2==) . packageId) (depends pkg1) ]
+ , any ((pkgid1==) . packageId) (sourceDeps pkg2)
+ || any ((pkgid2==) . packageId) (sourceDeps pkg1) ]
-- | The package targets.
diff --git a/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs b/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
index dc480e36b9..29632b67af 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
@@ -13,9 +13,10 @@
module Distribution.Client.Dependency.TopDown.Types where
import Distribution.Client.Types
- ( SourcePackage(..), InstalledPackage, OptionalStanza )
-import Distribution.Client.PackageIndex
- ( PackageFixedDeps(depends) )
+ ( SourcePackage(..), ReadyPackage(..), InstalledPackage(..)
+ , OptionalStanza )
+import Distribution.Client.InstallPlan
+ ( ConfiguredPackage(..), PlanPackage(..) )
import Distribution.Package
( PackageIdentifier, Dependency
@@ -65,9 +66,6 @@ data SemiConfiguredPackage
instance Package InstalledPackageEx where
packageId (InstalledPackageEx p _ _) = packageId p
-instance PackageFixedDeps InstalledPackageEx where
- depends (InstalledPackageEx _ _ deps) = deps
-
instance Package UnconfiguredPackage where
packageId (UnconfiguredPackage p _ _ _) = packageId p
@@ -91,3 +89,41 @@ instance (Package installed, Package source)
data InstalledConstraint = InstalledConstraint
| SourceConstraint
deriving (Eq, Show)
+
+-- | Package dependencies
+--
+-- The top-down solver uses its down type class for package dependencies,
+-- because it wants to know these dependencies as PackageIds, rather than as
+-- InstalledPackageIds (so it cannot use PackageFixedDeps).
+--
+-- Ideally we would switch the top-down solver over to use InstalledPackageIds
+-- throughout; that means getting rid of this type class, and changing over the
+-- package index type to use Cabal's rather than cabal-install's. That will
+-- avoid the need for the local definitions of dependencyGraph and
+-- reverseTopologicalOrder in the top-down solver.
+--
+-- Note that the top-down solver does not (and probably will never) make a
+-- distinction between the various kinds of dependencies, so we return a flat
+-- list here. If we get rid of this type class then any use of `sourceDeps`
+-- should be replaced by @fold . depends@.
+class Package a => PackageSourceDeps a where
+ sourceDeps :: a -> [PackageIdentifier]
+
+instance PackageSourceDeps InstalledPackageEx where
+ sourceDeps (InstalledPackageEx _ _ deps) = deps
+
+instance PackageSourceDeps ConfiguredPackage where
+ sourceDeps (ConfiguredPackage _ _ _ deps) = deps
+
+instance PackageSourceDeps ReadyPackage where
+ sourceDeps (ReadyPackage _ _ _ deps) = map packageId deps
+
+instance PackageSourceDeps InstalledPackage where
+ sourceDeps (InstalledPackage _ deps) = deps
+
+instance PackageSourceDeps PlanPackage where
+ sourceDeps (PreExisting pkg) = sourceDeps pkg
+ sourceDeps (Configured pkg) = sourceDeps pkg
+ sourceDeps (Processing pkg) = sourceDeps pkg
+ sourceDeps (Installed pkg _) = sourceDeps pkg
+ sourceDeps (Failed pkg _) = sourceDeps pkg
--
GitLab