[commit: Cabal] master: Make use of the package version preference in the top-down resolver (33f60d7)

[Ian Lynagh]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/33f60d7340b5fd1a2f895183c263926d3c718a3f

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

commit 33f60d7340b5fd1a2f895183c263926d3c718a3f
Author: Duncan Coutts <duncan at haskell.org>
Date:   Mon Jun 2 18:32:43 2008 +0000

    Make use of the package version preference in the top-down resolver

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

 cabal-install/Hackage/Dependency/TopDown.hs |   35 +++++++++++++++++----------
 1 files changed, 22 insertions(+), 13 deletions(-)

diff --git a/cabal-install/Hackage/Dependency/TopDown.hs b/cabal-install/Hackage/Dependency/TopDown.hs
index 724bc0e..45c2422 100644
--- a/cabal-install/Hackage/Dependency/TopDown.hs
+++ b/cabal-install/Hackage/Dependency/TopDown.hs
@@ -82,19 +82,21 @@ data SearchSpace inherited pkg
 -- * Traverse a search tree
 -- ------------------------------------------------------------
 
-explore :: SearchSpace a SelectablePackage
+explore :: (PackageName -> PackageVersionPreference)
+        -> SearchSpace a SelectablePackage
         -> Progress Log Failure a
 
-explore (Failure failure)      = Fail failure
-explore (ChoiceNode result []) = Done result
-explore (ChoiceNode _ choices) =
+explore _    (Failure failure)      = Fail failure
+explore _explore    (ChoiceNode result []) = Done result
+explore pref (ChoiceNode _ choices) =
   case [ choice | [choice] <- choices ] of
-    ((pkg, node'):_) -> Step (Select pkg [])    (explore node')
+    ((pkg, node'):_) -> Step (Select pkg [])    (explore pref node')
     []               -> seq pkgs' -- avoid retaining defaultChoice
-                      $ Step (Select pkg pkgs') (explore node')
+                      $ Step (Select pkg pkgs') (explore pref node')
       where
         choice       = minimumBy (comparing topSortNumber) choices
-        (pkg, node') = maximumBy (comparing (packageId . fst)) choice
+        pkgname      = packageName . fst . head $ choice
+        (pkg, node') = maximumBy (bestByPref pkgname) choice
         pkgs' = deleteBy (equating packageId) pkg (map fst choice)
 
   where
@@ -103,6 +105,12 @@ explore (ChoiceNode _ choices) =
       AvailableOnly           (UnconfiguredPackage _ i) -> i
       InstalledAndAvailable _ (UnconfiguredPackage _ i) -> i
 
+    bestByPref pkgname = case pref pkgname of
+      PreferLatest    -> comparing (\(p,_) ->                 packageId p)
+      PreferInstalled -> comparing (\(p,_) -> (isInstalled p, packageId p))
+      where isInstalled (AvailableOnly _) = False
+            isInstalled _                 = True
+
 -- ------------------------------------------------------------
 -- * Generate a search tree
 -- ------------------------------------------------------------
@@ -173,11 +181,12 @@ constrainDeps pkg (dep:deps) cs =
 -- ------------------------------------------------------------
 
 search :: ConfigurePackage
+       -> (PackageName -> PackageVersionPreference)
        -> Constraints
        -> Set PackageName
        -> Progress Log Failure (SelectedPackages, Constraints)
-search configure constraints =
-  explore . searchSpace configure constraints mempty
+search configure pref constraints =
+  explore pref . searchSpace configure constraints mempty
 
 -- ------------------------------------------------------------
 -- * The top level resolver
@@ -200,13 +209,13 @@ topDownResolver' :: OS -> Arch -> CompilerId
                  -> (PackageName -> PackageVersionPreference)
                  -> [UnresolvedDependency]
                  -> Progress Log Failure [PlanPackage a]
-topDownResolver' os arch comp installed available _ deps =
+topDownResolver' os arch comp installed available pref deps =
       fmap (uncurry finalise)
-    . (\cs -> search (configurePackage os arch comp) cs initialPkgNames)
+    . (\cs -> search configure pref cs initialPkgNames)
   =<< constrainTopLevelDeps deps constraints
 
   where
-    --TODO add actual constraints using addTopLevelDependencyConstraint
+    configure   = configurePackage os arch comp
     constraints = Constraints.empty
                     (annotateInstalledPackages topSortNumber installed)
                     (annotateAvailablePackages topSortNumber available)
@@ -238,7 +247,7 @@ configurePackage os arch comp available spkg = case spkg of
   where
   configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _) =
     case finalizePackageDescription [] (Just available) os arch comp [] p of
-      Left missing        -> Left missing
+      Left missing       -> Left missing
       Right (pkg, flags) -> Right $
         SemiConfiguredPackage apkg flags (buildDepends pkg)