[commit: Cabal] master: Update the solver to use the new target tracking (7185c25)

[Ian Lynagh]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/7185c2549f323f1509134c2dd1af3c3c5399a368

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

commit 7185c2549f323f1509134c2dd1af3c3c5399a368
Author: Duncan Coutts <duncan at community.haskell.org>
Date:   Sun Mar 27 14:57:56 2011 +0000

    Update the solver to use the new target tracking
    The constraint set ADT now needs to be told which targets we are
    interested in, rather than assuming anything we constrain might
    be a target.

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

 .../Distribution/Client/Dependency/TopDown.hs      |   49 ++++++++++++++++----
 1 files changed, 40 insertions(+), 9 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal-install/Distribution/Client/Dependency/TopDown.hs
index 18ab3f2..d8965a5 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown.hs
@@ -145,6 +145,10 @@ searchSpace :: ConfigurePackage
             -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)
                            SelectablePackage
 searchSpace configure constraints selected changes next =
+  assert (Set.null (selectedSet `Set.intersection` next)) $
+  assert (selectedSet `Set.isSubsetOf` Constraints.packages constraints) $
+  assert (next `Set.isSubsetOf` Constraints.packages constraints) $
+
   ChoiceNode (selected, constraints, changes)
     [ [ (pkg, select name pkg)
       | pkg <- PackageIndex.lookupPackageName available name ]
@@ -152,15 +156,18 @@ searchSpace configure constraints selected changes next =
   where
     available = Constraints.choices constraints
 
+    selectedSet = Set.fromList (map packageName (PackageIndex.allPackages selected))
+
     select name pkg = case configure available pkg of
       Left missing -> Failure $ ConfigureFailed pkg
                         [ (dep, Constraints.conflicting constraints dep)
                         | dep <- missing ]
-      Right pkg' -> case constrainDeps pkg' newDeps constraints [] of
-        Left failure       -> Failure failure
-        Right (constraints', newDiscarded) ->
-          searchSpace configure
-            constraints' selected' (newSelected, newDiscarded) next'
+      Right pkg' ->
+        case constrainDeps pkg' newDeps (addDeps constraints newPkgs) [] of
+          Left failure       -> Failure failure
+          Right (constraints', newDiscarded) ->
+            searchSpace configure
+              constraints' selected' (newSelected, newDiscarded) next'
         where
           selected' = foldl' (flip PackageIndex.insert) selected newSelected
           newSelected =
@@ -192,6 +199,13 @@ packageConstraints = either installedConstraints availableConstraints
     availableConstraints (SemiConfiguredPackage _ _ deps) =
       [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]
 
+addDeps :: Constraints -> [PackageName] -> Constraints
+addDeps =
+  foldr $ \pkgname cs ->
+            case Constraints.addTarget pkgname cs of
+              Satisfiable cs' () -> cs'
+              _                  -> impossible
+
 constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints
               -> [PackageId]
               -> Either Failure (Constraints, [PackageId])
@@ -244,12 +258,13 @@ topDownResolver' platform comp installedPkgIndex sourcePkgIndex
                  preferences constraints targets =
       fmap (uncurry finalise)
     . (\cs -> search configure preferences cs initialPkgNames)
-  =<< addTopLevelConstraints constraints constraintSet
+  =<< addTopLevelConstraints constraints
+  =<< addTopLevelTargets targets emptyConstraintSet
 
   where
     configure   = configurePackage platform comp
-    constraintSet :: Constraints
-    constraintSet = Constraints.empty
+    emptyConstraintSet :: Constraints
+    emptyConstraintSet = Constraints.empty
       (annotateInstalledPackages          topSortNumber installedPkgIndex')
       (annotateSourcePackages constraints topSortNumber sourcePkgIndex')
     (installedPkgIndex', sourcePkgIndex') =
@@ -264,6 +279,18 @@ topDownResolver' platform comp installedPkgIndex sourcePkgIndex
       . PackageIndex.fromList
       $ finaliseSelectedPackages preferences selected' constraints'
 
+
+addTopLevelTargets :: [PackageName]
+                   -> Constraints
+                   -> Progress a Failure Constraints
+addTopLevelTargets []         cs = Done cs
+addTopLevelTargets (pkg:pkgs) cs =
+  case Constraints.addTarget pkg cs of
+    Satisfiable cs' ()       -> addTopLevelTargets pkgs cs'
+    Unsatisfiable            -> Fail (NoSuchPackage pkg)
+    ConflictsWith _conflicts -> impossible
+
+
 addTopLevelConstraints :: [PackageConstraint] -> Constraints
                        -> Progress a Failure Constraints
 addTopLevelConstraints []                                      cs = Done cs
@@ -668,7 +695,9 @@ showExclusionReason pkgid (ExcludedByTopLevelDependency dep) =
 
 data Log = Select [SelectedPackage] [PackageId]
 data Failure
-   = ConfigureFailed
+   = NoSuchPackage
+       PackageName
+   | ConfigureFailed
        SelectablePackage
        [(Dependency, [(PackageId, [ExclusionReason])])]
    | DependencyConflict
@@ -712,6 +741,8 @@ showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of
         , element <- display pkgid : map (display . packageVersion) pkgids ]
 
 showFailure :: Failure -> String
+showFailure (NoSuchPackage pkgname) =
+     "The package " ++ display pkgname ++ " is unknown."
 showFailure (ConfigureFailed pkg missingDeps) =
      "cannot configure " ++ displayPkg pkg ++ ". It requires "
   ++ listOf (displayDep . fst) missingDeps