[commit: Cabal] master: Generalise the way preferences are specified to the resolver (85af264)

[Ian Lynagh]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/85af264568164e310cdc6b9da3bde1deaecbc9d8

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

commit 85af264568164e310cdc6b9da3bde1deaecbc9d8
Author: Duncan Coutts <duncan at haskell.org>
Date:   Thu Dec 18 20:49:17 2008 +0000

    Generalise the way preferences are specified to the resolver
    We still provide a default global policy, but now we give a
    list of per-package preferences which can be on the version
    or installed state. Later preferences override earlier ones.

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

 cabal-install/Distribution/Client/Dependency.hs |   65 ++++++++++++----------
 cabal-install/Distribution/Client/Fetch.hs      |    2 +-
 cabal-install/Distribution/Client/Install.hs    |    8 ++--
 3 files changed, 40 insertions(+), 35 deletions(-)

diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs
index 5a13fb1..10c3947 100644
--- a/cabal-install/Distribution/Client/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency.hs
@@ -22,8 +22,8 @@ module Distribution.Client.Dependency (
 
     PackagesPreference(..),
     packagesPreference,
-    PackagesVersionPreference,
-    PackagesInstalledPreference(..),
+    PackagesPreferenceDefault(..),
+    PackagePreference(..),
 
     upgradableDependencies,
   ) where
@@ -68,22 +68,15 @@ defaultResolver = topDownResolver
 -- | Global policy for the versions of all packages.
 --
 data PackagesPreference = PackagesPreference
-       PackagesInstalledPreference
-       PackagesVersionPreference
+       PackagesPreferenceDefault
+       [PackagePreference]
 
-packagesPreference :: PackagesInstalledPreference
+packagesPreference :: PackagesPreferenceDefault
                    -> Map PackageName VersionRange
                    -> PackagesPreference
-packagesPreference installedPref versionPrefs =
-  PackagesPreference installedPref versionPrefs'
-  where
-    versionPrefs' :: PackageName -> VersionRange
-    versionPrefs' pkgname =
-      fromMaybe AnyVersion (Map.lookup pkgname versionPrefs)
-
--- | An optional suggested version for each package.

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

-type PackagesVersionPreference = PackageName -> VersionRange
+packagesPreference defaultPref versionPrefs =
+  PackagesPreference defaultPref [ PackageVersionPreference name ver
+                                 | (name, ver) <- Map.toList versionPrefs ]
 
 dependencyConstraints :: [UnresolvedDependency] -> [PackageConstraint]
 dependencyConstraints deps =
@@ -102,7 +95,7 @@ dependencyTargets deps =
 -- | Global policy for all packages to say if we prefer package versions that
 -- are already installed locally or if we just prefer the latest available.
 --
-data PackagesInstalledPreference =
+data PackagesPreferenceDefault =
 
      -- | Always prefer the latest version irrespective of any existing
      -- installed version.
@@ -123,6 +116,10 @@ data PackagesInstalledPreference =
      --
    | PreferLatestForSelected
 
+data PackagePreference
+   = PackageVersionPreference   PackageName VersionRange
+   | PackageInstalledPreference PackageName InstalledPreference
+
 resolveDependencies :: Platform
                     -> CompilerId
                     -> Maybe (PackageIndex InstalledPackageInfo)
@@ -208,21 +205,29 @@ dependencyResolver resolver platform comp installed available
 interpretPackagesPreference :: Set PackageName
                             -> PackagesPreference
                             -> (PackageName -> PackagePreferences)
-interpretPackagesPreference selected
-  (PackagesPreference installPref versionPref) = case installPref of
+interpretPackagesPreference selected (PackagesPreference defaultPref prefs) =
+  \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)
 
-  PreferAllLatest         -> \pkgname ->
-    PackagePreferences (versionPref pkgname) PreferLatest
-
-  PreferAllInstalled      -> \pkgname ->
-    PackagePreferences (versionPref pkgname) PreferInstalled
-
-  PreferLatestForSelected -> \pkgname ->
-    -- When you say cabal install foo, what you really mean is, prefer the
-    -- latest version of foo, but the installed version of everything else:
-    if pkgname `Set.member` selected
-      then PackagePreferences (versionPref pkgname) PreferLatest
-      else PackagePreferences (versionPref pkgname) PreferInstalled
+  where
+    versionPref pkgname =
+      fromMaybe AnyVersion (Map.lookup pkgname versionPrefs)
+    versionPrefs = Map.fromList
+      [ (pkgname, pref)
+      | PackageVersionPreference pkgname pref <- prefs ]
+
+    installPref pkgname =
+      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)
+    installPrefs = Map.fromList
+      [ (pkgname, pref)
+      | PackageInstalledPreference pkgname pref <- prefs ]
+    installPrefDefault = case defaultPref of
+      PreferAllLatest         -> \_       -> PreferLatest
+      PreferAllInstalled      -> \_       -> PreferInstalled
+      PreferLatestForSelected -> \pkgname ->
+        -- When you say cabal install foo, what you really mean is, prefer the
+        -- latest version of foo, but the installed version of everything else
+        if pkgname `Set.member` selected then PreferLatest
+                                         else PreferInstalled
 
 -- | Given the list of installed packages and available packages, figure
 -- out which packages can be upgraded.
diff --git a/cabal-install/Distribution/Client/Fetch.hs b/cabal-install/Distribution/Client/Fetch.hs
index b8cb353..78e12c6 100644
--- a/cabal-install/Distribution/Client/Fetch.hs
+++ b/cabal-install/Distribution/Client/Fetch.hs
@@ -28,7 +28,7 @@ import Distribution.Client.Types
 import Distribution.Client.Dependency
          ( resolveDependenciesWithProgress
          , dependencyConstraints, dependencyTargets
-         , packagesPreference, PackagesInstalledPreference(..) )
+         , packagesPreference, PackagesPreferenceDefault(..) )
 import Distribution.Client.Dependency.Types
          ( foldProgress )
 import Distribution.Client.IndexUtils as IndexUtils
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 0437a49..d50d66a 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -35,7 +35,7 @@ import System.IO.Error
 import Distribution.Client.Dependency
          ( resolveDependenciesWithProgress
          , PackageConstraint(..), dependencyConstraints, dependencyTargets
-         , packagesPreference, PackagesInstalledPreference(..)
+         , packagesPreference, PackagesPreferenceDefault(..)
          , upgradableDependencies
          , Progress(..), foldProgress, )
 import Distribution.Client.Fetch (fetchPackage)
@@ -295,10 +295,10 @@ planLocalPackage verbosity comp configFlags installed
 
 -- | Make an 'InstallPlan' for the given dependencies.
 --
-planRepoPackages :: PackagesInstalledPreference -> Compiler
+planRepoPackages :: PackagesPreferenceDefault -> Compiler
                  -> Cabal.ConfigFlags -> InstallFlags
                  -> [UnresolvedDependency] -> Planner
-planRepoPackages installedPref comp configFlags installFlags deps installed
+planRepoPackages defaultPref comp configFlags installFlags deps installed
   (AvailablePackageDb available versionPrefs) = do
   deps' <- IndexUtils.disambiguateDependencies available deps
   let installed'
@@ -311,7 +311,7 @@ planRepoPackages installedPref comp configFlags installFlags deps installed
                     | Dependency name ver <- Cabal.configConstraints configFlags ]
   return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)
              installed' available
-             (packagesPreference installedPref versionPrefs)
+             (packagesPreference defaultPref versionPrefs)
              constraints targets
   where
     hideGivenDeps pkgs index =