[commit: Cabal] master: Use a more precise package substitution test in improvePlan (3143edf)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/3143edfa4b3aa8eb131058da02fd3096b2153705

>---------------------------------------------------------------

commit 3143edfa4b3aa8eb131058da02fd3096b2153705
Author: Duncan Coutts <duncan at haskell.org>
Date:   Fri Dec 19 21:59:22 2008 +0000

    Use a more precise package substitution test in improvePlan
    This is where we take a valid plan and we "improve" it by swapping
    installed packages for available packages wherever possible. This
    change is to the condition we use in deciding if it is safe to use
    the installed package in place of a reinstall. Previously we checked
    that the dependencies of the installed version were exactly the same
    as the dependencies we were planning to reinstall with. That was
    valid but rather conservative. It caused problems in some situations
    where the installed package did not exactly match the available
    package (eg when using development versions of a package or of ghc).
    What we do now is test if the extra constraints implied by selecting
    the installed version are consistent with the existing set of
    constraints. This involves threading the constraint set around. In
    theory this should even cope with adding additional packages to the
    plan as a result of selecting an installed package.

>---------------------------------------------------------------

 .../Distribution/Client/Dependency/TopDown.hs      |   66 ++++++++++++++------
 1 files changed, 47 insertions(+), 19 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal-install/Distribution/Client/Dependency/TopDown.hs
index 84e0bd3..33353e6 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown.hs
@@ -54,7 +54,7 @@ import Distribution.Text
 import Data.List
          ( foldl', maximumBy, minimumBy, nub, sort, groupBy )
 import Data.Maybe
-         ( fromJust, fromMaybe )
+         ( fromJust, fromMaybe, catMaybes )
 import Data.Monoid
          ( Monoid(mempty) )
 import Control.Monad
@@ -254,10 +254,11 @@ topDownResolver' platform comp installed available
 
     initialPkgNames = Set.fromList targets
 
-    finalise selected = PackageIndex.allPackages
-                      . improvePlan installed'
-                      . PackageIndex.fromList
-                      . finaliseSelectedPackages preferences selected
+    finalise selected' constraints' =
+        PackageIndex.allPackages
+      . fst . improvePlan installed' constraints'
+      . PackageIndex.fromList
+      $ finaliseSelectedPackages preferences selected' constraints'
 
 addTopLevelConstraints :: [PackageConstraint] -> Constraints
                        -> Progress a Failure Constraints
@@ -462,35 +463,62 @@ finaliseSelectedPackages pref selected constraints =
 
 -- | 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 InstalledPackageInfo
+            -> Constraints
             -> PackageIndex PlanPackage
-            -> PackageIndex PlanPackage
-improvePlan installed selected = foldl' improve selected
-                               $ reverseTopologicalOrder selected
+            -> (PackageIndex PlanPackage, Constraints)
+improvePlan installed constraints0 selected0 =
+  foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)
   where
-    improve selected' = maybe selected' (flip PackageIndex.insert selected')
-                      . improvePkg selected'
+    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' pkgid = do
-      Configured pkg  <- PackageIndex.lookupPackageId selected' pkgid
+    improvePkg selected constraints pkgid = do
+      Configured pkg  <- PackageIndex.lookupPackageId selected  pkgid
       ipkg            <- PackageIndex.lookupPackageId installed pkgid
-      guard $ sort (depends pkg) == nub (sort (depends ipkg))
-      guard $ all (isInstalled selected') (depends pkg)
-      return (PreExisting ipkg)
+      guard $ all (isInstalled selected) (depends pkg)
+      tryInstalled selected constraints [ipkg]
 
-    isInstalled selected' pkgid =
-      case PackageIndex.lookupPackageId selected' pkgid of
+    isInstalled selected pkgid =
+      case PackageIndex.lookupPackageId selected pkgid of
         Just (PreExisting _) -> True
         _                    -> False
 
-    reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg
-                            -> [PackageIdentifier]
+    tryInstalled :: PackageIndex PlanPackage -> Constraints
+                 -> [InstalledPackageInfo]
+                 -> 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 constraints of
+        Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'
+        _                          -> Nothing
+      where
+        dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid')
+
+    reverseTopologicalOrder :: PackageFixedDeps pkg
+                            => PackageIndex pkg -> [PackageIdentifier]
     reverseTopologicalOrder index = map (packageId . toPkg)
                                   . Graph.topSort
                                   . Graph.transposeG