[commit: Cabal] master: goal choice heuristic in modular solver: choose base as early as possible (f71491e)

[Ian Lynagh]

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

On branch  : master

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

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

commit f71491e10c1b229b11ea1ffa74fdac7dbf2bfece
Author: Andres Loeh <andres at well-typed.com>
Date:   Sat Oct 29 14:00:41 2011 +0000

    goal choice heuristic in modular solver: choose base as early as possible

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

 .../Client/Dependency/Modular/Preference.hs        |   14 ++++++++++++++
 .../Client/Dependency/Modular/Solver.hs            |    4 ++--
 2 files changed, 16 insertions(+), 2 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 8404bf0..593738f 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -188,6 +188,20 @@ firstGoal = trav go
     go x                = x
     -- Note that we keep empty choice nodes, because they mean success.
 
+-- | Transformation that tries to make a decision on base as early as
+-- possible. In nearly all cases, there's a single choice for the base
+-- package. Also, fixing base early should lead to better error messages.
+preferBaseGoalChoice :: Tree a -> Tree a
+preferBaseGoalChoice = trav go
+  where
+    go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs)
+    go x                = x
+
+    preferBase :: OpenGoal -> OpenGoal -> Ordering
+    preferBase (OpenGoal (Simple (Dep (Q [] pn) _)) _) _ | unPN pn == "base" = LT
+    preferBase _ (OpenGoal (Simple (Dep (Q [] pn) _)) _) | unPN pn == "base" = GT
+    preferBase _ _                                                           = EQ
+
 -- | Transformation that sorts choice nodes so that
 -- child nodes with a small branching degree are preferred. As a
 -- special case, choices with 0 branches will be preferred (as they
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
index dc3b487..32781bf 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -40,8 +40,8 @@ solve sc idx userPrefs userConstraints userGoals =
   where
     explorePhase     = exploreTreeLog . backjump
     heuristicsPhase  = if preferEasyGoalChoices sc
-                         then P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices
-                         else id
+                         then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices
+                         else P.preferBaseGoalChoice
     preferencesPhase = P.preferPackagePreferences userPrefs
     validationPhase  = P.enforcePackageConstraints userConstraints .
                        validateTree idx