[commit: Cabal] master: Implement plan improvement (e3f0921)

[Paolo Capriotti]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/e3f092192780e05d44c8c0556f12d00a3e622eac

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

commit e3f092192780e05d44c8c0556f12d00a3e622eac
Author: Duncan Coutts <duncan at haskell.org>
Date:   Mon Jun 2 00:00:18 2008 +0000

    Implement plan improvement
    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.

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

 cabal-install/Hackage/Dependency/TopDown.hs |   64 +++++++++++++++++++++++----
 1 files changed, 55 insertions(+), 9 deletions(-)

diff --git a/cabal-install/Hackage/Dependency/TopDown.hs b/cabal-install/Hackage/Dependency/TopDown.hs
index 3a822a4..7fc8cae 100644
--- a/cabal-install/Hackage/Dependency/TopDown.hs
+++ b/cabal-install/Hackage/Dependency/TopDown.hs
@@ -19,6 +19,8 @@ import qualified Hackage.Dependency.TopDown.Constraints as Constraints
 import Hackage.Dependency.TopDown.Constraints
          ( Satisfiable(..) )
 import qualified Hackage.InstallPlan as InstallPlan
+import Hackage.InstallPlan
+         ( PlanPackage(..) )
 import Hackage.Types
          ( UnresolvedDependency(..), AvailablePackage(..)
          , ConfiguredPackage(..) )
@@ -30,10 +32,11 @@ import qualified Hackage.Dependency.Types as Progress
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 import Distribution.Simple.PackageIndex (PackageIndex)
 import Distribution.InstalledPackageInfo
-         ( InstalledPackageInfo, depends )
+         ( InstalledPackageInfo )
 import Distribution.Package
          ( PackageIdentifier, Package(packageId), packageVersion, packageName
-         , Dependency(Dependency), thisPackageVersion, notThisPackageVersion )
+         , Dependency(Dependency), thisPackageVersion, notThisPackageVersion
+         , PackageFixedDeps(depends) )
 import Distribution.PackageDescription
          ( PackageDescription(buildDepends) )
 import Distribution.PackageDescription.Configuration
@@ -48,11 +51,13 @@ import Distribution.Text
          ( display )
 
 import Data.List
-         ( maximumBy, minimumBy, deleteBy, nub )
+         ( foldl', maximumBy, minimumBy, deleteBy, nub, sort )
 import Data.Maybe
-         ( fromJust )
+         ( fromJust, catMaybes )
 import Data.Monoid
          ( Monoid(mempty) )
+import Control.Monad
+         ( guard )
 import qualified Data.Set as Set
 import Data.Set (Set)
 import qualified Data.Graph as Graph
@@ -131,7 +136,8 @@ searchSpace configure constraints selected next =
                         , let (Dependency name' _) = untagDependency dep
                         , null (PackageIndex.lookupPackageName selected' name') ]
             newDeps   = packageConstraints pkg'
-            next'     = Set.delete name $ foldr Set.insert next newPkgs
+            next'     = Set.delete name
+                      $ foldl' (flip Set.insert) next newPkgs
          in case constrainDeps pkg' newDeps constraints of
               Left failure       -> Failure failure
               Right constraints' -> searchSpace configure
@@ -195,9 +201,9 @@ topDownResolver' :: OS -> Arch -> CompilerId
                  -> PackageIndex InstalledPackageInfo
                  -> PackageIndex AvailablePackage
                  -> [UnresolvedDependency]
-                 -> Progress Log Failure [InstallPlan.PlanPackage a]
+                 -> Progress Log Failure [PlanPackage a]
 topDownResolver' os arch comp installed available deps =
-    fmap (uncurry finaliseSelectedPackages)
+    fmap (uncurry finalise)
   $ search (configurePackage os arch comp) constraints initialPkgNames
 
   where
@@ -210,6 +216,11 @@ topDownResolver' os arch comp installed available deps =
     initialDeps     = [ dep  | UnresolvedDependency dep _ <- deps ]
     initialPkgNames = Set.fromList [ name | Dependency name _ <- initialDeps ]
 
+    finalise selected = PackageIndex.allPackages
+                      . improvePlan installed
+                      . PackageIndex.fromList
+                      . finaliseSelectedPackages selected
+
 configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage
 configurePackage os arch comp available spkg = case spkg of
   InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)
@@ -295,7 +306,7 @@ topologicalSortNumbering installed available =
 
 finaliseSelectedPackages :: SelectedPackages
                          -> Constraints
-                         -> [InstallPlan.PlanPackage a]
+                         -> [PlanPackage a]
 finaliseSelectedPackages selected constraints =
   map finaliseSelected (PackageIndex.allPackages selected)
   where
@@ -308,7 +319,6 @@ finaliseSelectedPackages selected 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) =
@@ -319,6 +329,42 @@ finaliseSelectedPackages selected constraints =
                                    [pkg''] -> pkg''
                                    _ -> impossible ]
 
+-- | Improve an existing installation plan by, where possible, swapping
+-- packages we plan to install with ones that are already installed.
+--
+improvePlan :: PackageIndex InstalledPackageInfo
+            -> PackageIndex (PlanPackage a)
+            -> PackageIndex (PlanPackage a)
+improvePlan installed selected = foldl' improve selected
+                               $ reverseTopologicalOrder selected
+  where
+    improve selected' = maybe selected' (flip PackageIndex.insert selected')
+                      . improvePkg
+
+    -- 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 pkgid = do
+      Configured pkg  <- PackageIndex.lookupPackageId selected  pkgid
+      ipkg            <- PackageIndex.lookupPackageId installed pkgid
+      guard $ sort (depends pkg) == sort (depends ipkg)
+      guard $ all isInstalled (depends pkg)
+      return (PreExisting ipkg)
+
+    isInstalled pkgid = case PackageIndex.lookupPackageId selected pkgid of
+      Just (PreExisting _) -> True
+      _                    -> False
+
+    reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg
+                            -> [PackageIdentifier]
+    reverseTopologicalOrder index = map toPkgId
+                                  . Graph.topSort
+                                  . Graph.transposeG
+                                  $ graph
+      where (graph, toPkgId, _) = PackageIndex.dependencyGraph index
+
 -- ------------------------------------------------------------
 -- * Adding and recording constraints
 -- ------------------------------------------------------------