[commit: Cabal] master: Use new simplistic package resolver for cabal unpack (b0e99f9)

[Ian Lynagh]

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

On branch  : master

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

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

commit b0e99f9e7950830cc1035f3f608878e98896e10b
Author: Duncan Coutts <duncan at haskell.org>
Date:   Fri May 28 01:15:23 2010 +0000

    Use new simplistic package resolver for cabal unpack

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

 cabal-install/Distribution/Client/Unpack.hs |   77 ++++++++++++++-------------
 1 files changed, 40 insertions(+), 37 deletions(-)

diff --git a/cabal-install/Distribution/Client/Unpack.hs b/cabal-install/Distribution/Client/Unpack.hs
index 1705e8e..ce7780b 100644
--- a/cabal-install/Distribution/Client/Unpack.hs
+++ b/cabal-install/Distribution/Client/Unpack.hs
@@ -18,16 +18,13 @@ module Distribution.Client.Unpack (
   ) where
 
 import Distribution.Package
-         ( PackageId, packageId, Dependency(..) )
-import Distribution.Client.PackageIndex as PackageIndex (lookupDependency)
+         ( PackageId, Dependency(..) )
 import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault)
 import Distribution.Simple.Utils
          ( notice, die )
 import Distribution.Verbosity
          ( Verbosity )
 import Distribution.Text(display)
-import Distribution.Version
-         ( anyVersion, intersectVersionRanges )
 
 import Distribution.Client.Setup(UnpackFlags(unpackVerbosity,
                                              unpackDestDir))
@@ -35,6 +32,11 @@ import Distribution.Client.Types(UnresolvedDependency(..),
                                  Repo, AvailablePackageSource(..),
                                  AvailablePackage(AvailablePackage),
                                  AvailablePackageDb(AvailablePackageDb))
+import Distribution.Client.Dependency as Dependency
+         ( resolveAvailablePackages
+         , dependencyConstraints, dependencyTargets
+         , PackagesPreference(..), PackagesPreferenceDefault(..)
+         , PackagePreference(..) )
 import Distribution.Client.Fetch
         ( fetchPackage )
 import Distribution.Client.HttpUtils
@@ -50,38 +52,35 @@ import System.IO
          ( openTempFile, hClose )
 import Control.Monad
          ( unless, when )
-import Data.Ord (comparing)
-import Data.List(maximumBy)
+import Data.Monoid
+         ( mempty )
 import System.FilePath
          ( (</>), addTrailingPathSeparator )
 import qualified Data.Map as Map
 
 unpack :: UnpackFlags -> [Repo] -> [Dependency] -> IO ()
-unpack flags repos deps 
-    | null deps = notice verbosity
-                  "No packages requested. Nothing to do."
-    | otherwise = do
+unpack flags _ [] =
+    notice verbosity "No packages requested. Nothing to do."
+  where
+    verbosity = fromFlag (unpackVerbosity flags)
+
+unpack flags repos deps = do
   db@(AvailablePackageDb available _)
             <- getAvailablePackages verbosity repos
-  deps' <- fmap (map dependency) 
-           . IndexUtils.disambiguateDependencies available 
-           . map toUnresolved $ deps
+  deps' <- IndexUtils.disambiguateDependencies available
+         . map toUnresolved $ deps
 
-  let pkgs = resolvePackages db deps'
+  pkgs <- resolvePackages db deps'
 
   unless (null prefix) $
          createDirectoryIfMissing True prefix
 
   flip mapM_ pkgs $ \pkg -> case pkg of
 
-    Left (Dependency name ver) ->
-      die $ "There is no available version of " ++ display name
-            ++ " that satisfies " ++ display ver
-
-    Right (AvailablePackage pkgid _ (LocalTarballPackage tarballPath)) ->
+    AvailablePackage pkgid _ (LocalTarballPackage tarballPath) ->
       unpackPackage verbosity prefix pkgid tarballPath
 
-    Right (AvailablePackage pkgid _ (RemoteTarballPackage tarballURL)) -> do
+    AvailablePackage pkgid _ (RemoteTarballPackage tarballURL) -> do
       tmp <- getTemporaryDirectory
       (tarballPath, hnd) <- openTempFile tmp (display pkgid)
       hClose hnd
@@ -91,11 +90,11 @@ unpack flags repos deps
       downloadURI verbosity tarballURL tarballPath
       unpackPackage verbosity prefix pkgid tarballPath
 
-    Right (AvailablePackage pkgid _ (RepoTarballPackage repo)) -> do
+    AvailablePackage pkgid _ (RepoTarballPackage repo) -> do
       tarballPath <- fetchPackage verbosity repo pkgid
       unpackPackage verbosity prefix pkgid tarballPath
 
-    Right (AvailablePackage _ _ (LocalUnpackedPackage _)) ->
+    AvailablePackage _ _ (LocalUnpackedPackage _) ->
       error "Distribution.Client.Unpack.unpack: the impossible happened."
 
     where
@@ -118,18 +117,22 @@ unpackPackage verbosity prefix pkgid pkgPath = do
     Tar.extractTarGzFile prefix pkgdirname pkgPath
 
 resolvePackages :: AvailablePackageDb
-                   -> [Dependency]
-                   -> [Either Dependency AvailablePackage]
-resolvePackages (AvailablePackageDb available prefs) deps =
-    map (\d -> best d (candidates d)) deps
-    where
-      candidates dep@(Dependency name ver) =
-          let [x,y] = map (PackageIndex.lookupDependency available)
-                      [ Dependency name
-                        (maybe anyVersion id (Map.lookup name prefs)
-                         `intersectVersionRanges` ver)
-                      , dep ]
-          in if null x then y else x
-      best d [] = Left d
-      best _ xs = Right $ maximumBy (comparing packageId) xs
-
+                -> [UnresolvedDependency]
+                -> IO [AvailablePackage]
+resolvePackages
+  (AvailablePackageDb available availablePrefs) deps =
+
+    either (die . unlines . map show) return $
+      resolveAvailablePackages
+        installed   available
+        preferences constraints
+        targets
+
+  where
+    installed   = mempty
+    targets     = dependencyTargets     deps
+    constraints = dependencyConstraints deps
+    preferences = PackagesPreference
+                    PreferLatestForSelected
+                    [ PackageVersionPreference name ver
+                    | (name, ver) <- Map.toList availablePrefs ]