[commit: Cabal] master: Support top level dependency version constraints (fca64b4)

[Ian Lynagh]

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

On branch  : master

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

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

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

    Support top level dependency version constraints
    and error messages for when they're unsatisfiable or conflict

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

 cabal-install/Hackage/Dependency/TopDown.hs |   51 ++++++++++++++++++++-------
 cabal-install/Hackage/Dependency/Types.hs   |    6 +++-
 2 files changed, 43 insertions(+), 14 deletions(-)

diff --git a/cabal-install/Hackage/Dependency/TopDown.hs b/cabal-install/Hackage/Dependency/TopDown.hs
index 7fc8cae..051d284 100644
--- a/cabal-install/Hackage/Dependency/TopDown.hs
+++ b/cabal-install/Hackage/Dependency/TopDown.hs
@@ -25,9 +25,7 @@ import Hackage.Types
          ( UnresolvedDependency(..), AvailablePackage(..)
          , ConfiguredPackage(..) )
 import Hackage.Dependency.Types
-         ( DependencyResolver, Progress )
-import qualified Hackage.Dependency.Types as Progress
-         ( Progress(..), foldProgress )
+         ( DependencyResolver, Progress(..), foldProgress )
 
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 import Distribution.Simple.PackageIndex (PackageIndex)
@@ -53,7 +51,7 @@ import Distribution.Text
 import Data.List
          ( foldl', maximumBy, minimumBy, deleteBy, nub, sort )
 import Data.Maybe
-         ( fromJust, catMaybes )
+         ( fromJust )
 import Data.Monoid
          ( Monoid(mempty) )
 import Control.Monad
@@ -86,13 +84,13 @@ data SearchSpace inherited pkg
 explore :: SearchSpace a SelectablePackage
         -> Progress Log Failure a
 
-explore (Failure failure)      = Progress.Fail failure
-explore (ChoiceNode result []) = Progress.Done result
+explore (Failure failure)      = Fail failure
+explore (ChoiceNode result []) = Done result
 explore (ChoiceNode _ choices) =
   case [ choice | [choice] <- choices ] of
-    ((pkg, node'):_) -> Progress.Step (Select pkg [])    (explore node')
+    ((pkg, node'):_) -> Step (Select pkg [])    (explore node')
     []               -> seq pkgs' -- avoid retaining defaultChoice
-                      $ Progress.Step (Select pkg pkgs') (explore node')
+                      $ Step (Select pkg pkgs') (explore node')
       where
         choice       = minimumBy (comparing topSortNumber) choices
         (pkg, node') = maximumBy (comparing (packageId . fst)) choice
@@ -191,9 +189,7 @@ topDownResolver :: DependencyResolver a
 topDownResolver = (((((mapMessages .).).).).) . topDownResolver'
   where
     mapMessages :: Progress Log Failure a -> Progress String String a
-    mapMessages = Progress.foldProgress (Progress.Step . showLog)
-                                        (Progress.Fail . showFailure)
-                                         Progress.Done
+    mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done
 
 -- | The native resolver with detailed structured logging and failure types.
 --
@@ -203,8 +199,9 @@ topDownResolver' :: OS -> Arch -> CompilerId
                  -> [UnresolvedDependency]
                  -> Progress Log Failure [PlanPackage a]
 topDownResolver' os arch comp installed available deps =
-    fmap (uncurry finalise)
-  $ search (configurePackage os arch comp) constraints initialPkgNames
+      fmap (uncurry finalise)
+    . (\cs -> search (configurePackage os arch comp) cs initialPkgNames)
+  =<< constrainTopLevelDeps deps constraints
 
   where
     --TODO add actual constraints using addTopLevelDependencyConstraint
@@ -221,6 +218,15 @@ topDownResolver' os arch comp installed available deps =
                       . PackageIndex.fromList
                       . finaliseSelectedPackages selected
 
+constrainTopLevelDeps :: [UnresolvedDependency] -> Constraints
+                      -> Progress a Failure Constraints
+constrainTopLevelDeps []                                cs = Done cs
+constrainTopLevelDeps (UnresolvedDependency dep _:deps) cs =
+  case addTopLevelDependencyConstraint dep cs of
+    Satisfiable cs'         -> constrainTopLevelDeps deps cs'
+    Unsatisfiable           -> Fail (TopLevelDependencyUnsatisfiable dep)
+    ConflictsWith conflicts -> Fail (TopLevelDependencyConflict dep conflicts)
+
 configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage
 configurePackage os arch comp available spkg = case spkg of
   InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)
@@ -440,6 +446,10 @@ showExclusionReason pkgid ExcludedByConfigureFail =
 showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) =
   display pkgid ++ " was excluded because " ++
   display pkgid' ++ " requires " ++ display (untagDependency dep)
+showExclusionReason pkgid (ExcludedByTopLevelDependency dep) =
+  display pkgid ++ " was excluded because of the top level dependency " ++
+  display dep
+
 
 -- ------------------------------------------------------------
 -- * Logging progress and failures
@@ -453,6 +463,11 @@ data Failure
    | DependencyConflict
        SelectedPackage TaggedDependency
        [(PackageIdentifier, [ExclusionReason])]
+   | TopLevelDependencyConflict
+       Dependency
+       [(PackageIdentifier, [ExclusionReason])]
+   | TopLevelDependencyUnsatisfiable
+       Dependency
 
 showLog :: Log -> String
 showLog (Select selected discarded) =
@@ -493,6 +508,16 @@ showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) =
   ++ unlines [ showExclusionReason (packageId pkg') reason
              | (pkg', reasons) <- conflicts, reason <- reasons ]
 
+showFailure (TopLevelDependencyConflict dep conflicts) =
+     "dependencies conflict: "
+  ++ "top level dependency " ++ display dep ++ " however\n"
+  ++ unlines [ showExclusionReason (packageId pkg') reason
+             | (pkg', reasons) <- conflicts, reason <- reasons ]
+
+showFailure (TopLevelDependencyUnsatisfiable (Dependency name ver)) =
+     "There is no available version of " ++ name
+      ++ " that satisfies " ++ display ver
+
 -- ------------------------------------------------------------
 -- * Utils
 -- ------------------------------------------------------------
diff --git a/cabal-install/Hackage/Dependency/Types.hs b/cabal-install/Hackage/Dependency/Types.hs
index 3b1ef54..be7beb3 100644
--- a/cabal-install/Hackage/Dependency/Types.hs
+++ b/cabal-install/Hackage/Dependency/Types.hs
@@ -69,5 +69,9 @@ foldProgress step fail done = fold
         fold (Fail f)   = fail f
         fold (Done r)   = done r
 
-instance Functor (Progress step failure) where
+instance Functor (Progress step fail) where
   fmap f = foldProgress Step Fail (Done . f)
+
+instance Monad (Progress step fail) where
+  return a = Done a
+  p >>= f  = foldProgress Step Fail f p