diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs
index 8f20e7a4f9c05747720ecbfe30a03014f8cfe380..10f2c0243dd729edc818b0364bea4a4217049f8a 100644
--- a/cabal-install/Distribution/Client/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency.hs
@@ -587,13 +587,12 @@ interpretPackagesPreference :: Set PackageName
-> (PackageName -> PackagePreferences)
interpretPackagesPreference selected defaultPref prefs =
\pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)
-
where
versionPref pkgname =
- fromMaybe anyVersion (Map.lookup pkgname versionPrefs)
- versionPrefs = Map.fromList
- [ (pkgname, pref)
- | PackageVersionPreference pkgname pref <- prefs ]
+ fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)
+ versionPrefs = Map.fromListWith (++)
+ [(pkgname, [pref])
+ | PackageVersionPreference pkgname pref <- prefs]
installPref pkgname =
fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)
@@ -818,7 +817,8 @@ resolveWithoutDependencies (DepResolverParams targets constraints
. InstalledPackageIndex.lookupSourcePackageId
installedPkgIndex
. packageId
- versionPref pkg = packageVersion pkg `withinRange` preferredVersions
+ versionPref pkg = length . filter (packageVersion pkg `withinRange`) $
+ preferredVersions
packageConstraints :: PackageName -> VersionRange
packageConstraints pkgname =
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 22ac151f55e07f0745f90ac20efd3693fb1cb1a6..90385bfcce4f59b920c0999daad60da9e7529925 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -74,11 +74,13 @@ preferLinked = trav go
cmpL (Just _) (Just _) = EQ
--- | Ordering that treats preferred versions as greater than non-preferred
--- versions.
-preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering
-preferredVersionsOrdering vr v1 v2 =
- compare (checkVR vr v1) (checkVR vr v2)
+-- | Ordering that treats versions satisfying more preferred ranges as greater
+-- than versions satisfying less preferred ranges.
+preferredVersionsOrdering :: [VR] -> Ver -> Ver -> Ordering
+preferredVersionsOrdering vrs v1 v2 = compare (check v1) (check v2)
+ where
+ check v = Prelude.length . Prelude.filter (==True) .
+ Prelude.map (flip checkVR v) $ vrs
-- | Traversal that tries to establish package preferences (not constraints).
-- Works by reordering choice nodes.
@@ -86,8 +88,8 @@ preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a
preferPackagePreferences pcs = packageOrderFor (const True) preference
where
preference pn i1@(I v1 _) i2@(I v2 _) =
- let PackagePreferences vr ipref = pcs pn
- in preferredVersionsOrdering vr v1 v2 `mappend` -- combines lexically
+ let PackagePreferences vrs ipref = pcs pn
+ in preferredVersionsOrdering vrs v1 v2 `mappend` -- combines lexically
locationsOrdering ipref i1 i2
-- Note that we always rank installed before uninstalled, and later
diff --git a/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal-install/Distribution/Client/Dependency/TopDown.hs
index e7bb9f1077bceea71ec7fcc4810f65eb4fd7db4a..f6f7823331b443bc783fe67042677f342b43000d 100644
--- a/cabal-install/Distribution/Client/Dependency/TopDown.hs
+++ b/cabal-install/Distribution/Client/Dependency/TopDown.hs
@@ -127,7 +127,9 @@ explore pref (ChoiceNode _ choices) =
where
isInstalled (SourceOnly _) = False
isInstalled _ = True
- isPreferred p = packageVersion p `withinRange` preferredVersions
+ isPreferred p = length . filter (packageVersion p `withinRange`) $
+ preferredVersions
+
(PackagePreferences preferredVersions packageInstalledPreference)
= pref pkgname
@@ -669,9 +671,11 @@ finaliseSelectedPackages pref selected constraints =
-- version constraints. TODO: distinguish hacks from prefs
bounded = boundedAbove versionRange
isPreferred p
- | bounded = True -- any constant will do
- | otherwise = packageVersion p `withinRange` preferredVersions
+ | bounded = boundedRank -- this is a dummy constant
+ | otherwise = length . filter (packageVersion p `withinRange`) $
+ preferredVersions
where (PackagePreferences preferredVersions _) = pref (packageName p)
+ boundedRank = 0 -- any value will do
boundedAbove :: VersionRange -> Bool
boundedAbove vr = case asVersionIntervals vr of
diff --git a/cabal-install/Distribution/Client/Dependency/Types.hs b/cabal-install/Distribution/Client/Dependency/Types.hs
index 9b643cfe5a84e38f013e7758116e777c33a218a8..a1821b679b02a64b65192eb8221481376148a83f 100644
--- a/cabal-install/Distribution/Client/Dependency/Types.hs
+++ b/cabal-install/Distribution/Client/Dependency/Types.hs
@@ -32,6 +32,7 @@ module Distribution.Client.Dependency.Types (
ConstraintSource(..),
unlabelPackageConstraint,
showConstraintSource
+
) where
#if !MIN_VERSION_base(4,8,0)
@@ -156,17 +157,18 @@ showPackageConstraint (PackageConstraintStanzas pn ss) =
showStanza TestStanzas = "test"
showStanza BenchStanzas = "bench"
--- | A per-package preference on the version. It is a soft constraint that the
+-- | Per-package preferences on the version. It is a soft constraint that the
-- 'DependencyResolver' should try to respect where possible. It consists of
--- a 'InstalledPreference' which says if we prefer versions of packages
--- that are already installed. It also has a 'PackageVersionPreference' which
--- is a suggested constraint on the version number. The resolver should try to
--- use package versions that satisfy the suggested version constraint.
+-- an 'InstalledPreference' which says if we prefer versions of packages
+-- that are already installed. It also has (possibly multiple)
+-- 'PackageVersionPreference's which are suggested constraints on the version
+-- number. The resolver should try to use package versions that satisfy
+-- the maximum number of the suggested version constraints.
--
-- It is not specified if preferences on some packages are more important than
-- others.
--
-data PackagePreferences = PackagePreferences VersionRange InstalledPreference
+data PackagePreferences = PackagePreferences [VersionRange] InstalledPreference
-- | Whether we prefer an installed version of a package or simply the latest
-- version.
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
index a5345fe7083be401b9733dcc923a9c2f83f90dc7..3c6ce7d2aa830b3f241672b2d0b5a3cae1806ce4 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs
@@ -2,7 +2,10 @@
-- | DSL for testing the modular solver
module UnitTests.Distribution.Client.Dependency.Modular.DSL (
ExampleDependency(..)
+ , ExPreference(..)
, ExampleDb
+ , ExampleVersionRange
+ , ExamplePkgVersion
, exAv
, exInst
, exResolve
@@ -84,6 +87,7 @@ type ExamplePkgVersion = Int
type ExamplePkgHash = String -- for example "installed" packages
type ExampleFlagName = String
type ExampleTestName = String
+type ExampleVersionRange = C.VersionRange
data ExampleDependency =
-- | Simple dependency on any version
@@ -104,6 +108,7 @@ data ExampleDependency =
-- | Dependency on a language version
| ExLang Language
+data ExPreference = ExPref String ExampleVersionRange
data ExampleAvailable = ExAv {
exAvName :: ExamplePkgName
@@ -304,8 +309,9 @@ exResolve :: ExampleDb
-> [Language]
-> [ExamplePkgName]
-> Bool
+ -> [ExPreference]
-> ([String], Either String CI.InstallPlan.InstallPlan)
-exResolve db exts langs targets indepGoals = runProgress $
+exResolve db exts langs targets indepGoals prefs = runProgress $
resolveDependencies C.buildPlatform
compiler
Modular
@@ -325,15 +331,17 @@ exResolve db exts langs targets indepGoals = runProgress $
packageIndex = exAvIdx avai
, packagePreferences = Map.empty
}
- enableTests = map (\p -> PackageConstraintStanzas
+ enableTests = fmap (\p -> PackageConstraintStanzas
(C.PackageName p) [TestStanzas])
(exDbPkgs db)
- targets' = map (\p -> NamedPackage (C.PackageName p) []) targets
- params = addConstraints (map toLpc enableTests)
- $ (standardInstallPolicy instIdx avaiIdx targets') {
- depResolverIndependentGoals = indepGoals
+ targets' = fmap (\p -> NamedPackage (C.PackageName p) []) targets
+ params = addPreferences (fmap toPref prefs)
+ $ addConstraints (fmap toLpc enableTests)
+ $ (standardInstallPolicy instIdx avaiIdx targets') {
+ depResolverIndependentGoals = indepGoals
}
toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
+ toPref (ExPref n v) = PackageVersionPreference (C.PackageName n) v
extractInstallPlan :: CI.InstallPlan.InstallPlan
-> [(ExamplePkgName, ExamplePkgVersion)]
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
index e7692d41b7eb7270ba2672e686d889c5f116bde2..be94ea7473900485ee78ba9d7b7055ab633bbf9a 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
@@ -8,6 +8,9 @@ import Data.Maybe (isNothing)
import Data.Proxy
import Data.Typeable
+import qualified Data.Version as V
+import qualified Distribution.Version as V
+
-- test-framework
import Test.Tasty as TF
import Test.Tasty.HUnit (testCase, assertEqual, assertBool)
@@ -85,9 +88,26 @@ tests = [
, runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] Nothing
, runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (Just [("A",1),("B",1),("C",1)])
]
+
+ , testGroup "Soft Constraints" [
+ runTest $ soft [ ExPref "A" $ mkvrThis 1] $ mkTest db13 "selectPreferredVersionSimple" ["A"] (Just [("A", 1)])
+ , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (Just [("A", 2)])
+ , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2
+ , ExPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (Just [("A", 1)])
+ , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 1
+ , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (Just [("A", 1)])
+ , runTest $ soft [ ExPref "A" $ mkvrThis 1
+ , ExPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (Just [("A", 2)])
+ , runTest $ soft [ ExPref "A" $ mkvrThis 1
+ , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (Just [("A", 1)])
+ ]
]
where
- indep test = test { testIndepGoals = True }
+ indep test = test { testIndepGoals = True }
+ soft prefs test = test { testSoftConstraints = prefs }
+ mkvrThis = V.thisVersion . makeV
+ mkvrOrEarlier = V.orEarlierVersion . makeV
+ makeV v = V.Version [v,0,0] []
{-------------------------------------------------------------------------------
Solver tests
@@ -98,6 +118,7 @@ data SolverTest = SolverTest {
, testTargets :: [String]
, testResult :: Maybe [(String, Int)]
, testIndepGoals :: Bool
+ , testSoftConstraints :: [ExPreference]
, testDb :: ExampleDb
, testSupportedExts :: [Extension]
, testSupportedLangs :: [Language]
@@ -138,6 +159,7 @@ mkTestExtLang exts langs db label targets result = SolverTest {
, testTargets = targets
, testResult = result
, testIndepGoals = False
+ , testSoftConstraints = []
, testDb = db
, testSupportedExts = exts
, testSupportedLangs = langs
@@ -146,7 +168,8 @@ mkTestExtLang exts langs db label targets result = SolverTest {
runTest :: SolverTest -> TF.TestTree
runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
testCase testLabel $ do
- let (_msgs, result) = exResolve testDb testSupportedExts testSupportedLangs testTargets testIndepGoals
+ let (_msgs, result) = exResolve testDb testSupportedExts testSupportedLangs
+ testTargets testIndepGoals testSoftConstraints
when showSolverLog $ mapM_ putStrLn _msgs
case result of
Left err -> assertBool ("Unexpected error:\n" ++ err) (isNothing testResult)
@@ -387,6 +410,13 @@ db12 =
, Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]
]
+db13 :: ExampleDb
+db13 = [
+ Right $ exAv "A" 1 []
+ , Right $ exAv "A" 2 []
+ , Right $ exAv "A" 3 []
+ ]
+
dbExts1 :: ExampleDb
dbExts1 = [
Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]
@@ -403,7 +433,6 @@ dbLangs1 = [
, Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]
]
-
{-------------------------------------------------------------------------------
Test options
-------------------------------------------------------------------------------}