[commit: Cabal] master: there may be more than one package constraint per package (1a17a84)
Ian Lynagh
igloo at earth.li
Fri Nov 4 18:07:33 CET 2011
Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/1a17a840c89d1699eaa598491873f4464b62edea
>---------------------------------------------------------------
commit 1a17a840c89d1699eaa598491873f4464b62edea
Author: Andres Loeh <andres at well-typed.com>
Date: Thu Oct 27 13:31:08 2011 +0000
there may be more than one package constraint per package
>---------------------------------------------------------------
.../Distribution/Client/Dependency/Modular.hs | 4 +-
.../Client/Dependency/Modular/Preference.hs | 76 ++++++++++---------
.../Client/Dependency/Modular/Solver.hs | 2 +-
3 files changed, 43 insertions(+), 39 deletions(-)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular.hs b/cabal-install/Distribution/Client/Dependency/Modular.hs
index 3953e3f..4c71139 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular.hs
@@ -10,7 +10,7 @@ module Distribution.Client.Dependency.Modular
-- plan.
import Data.Map as M
- ( fromList )
+ ( fromListWith )
import Distribution.Client.Dependency.Modular.Assignment
( Assignment, toCPs )
import Distribution.Client.Dependency.Modular.Dependency
@@ -43,7 +43,7 @@ modularResolver sc (Platform arch os) cid iidx sidx pprefs pcs pns =
-- Indices have to be converted into solver-specific uniform index.
idx = convPIs os arch cid iidx sidx
-- Constraints have to be converted into a finite map indexed by PN.
- gcs = M.fromList (map (\ pc -> (pcName pc, pc)) pcs)
+ gcs = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs)
-- Results have to be converted into an install plan.
postprocess :: Assignment -> RevDepMap -> [PlanPackage]
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index fd85275..79a8940 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -71,48 +71,52 @@ preferInstalledOrdering _ _ = EQ
preferLatestOrdering :: I -> I -> Ordering
preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2
+-- | Helper function that tries to enforce a single package constraint on a
+-- given instance for a P-node. Translates the constraint into a
+-- tree-transformer that either leaves the subtree untouched, or replaces it
+-- with an appropriate failure node.
+processPackageConstraintP :: ConflictSet QPN -> I -> PackageConstraint -> Tree a -> Tree a
+processPackageConstraintP c (I v _) (PackageConstraintVersion _ vr) r
+ | checkVR vr v = r
+ | otherwise = Fail c (GlobalConstraintVersion vr)
+processPackageConstraintP c i (PackageConstraintInstalled _) r
+ | instI i = r
+ | otherwise = Fail c GlobalConstraintInstalled
+processPackageConstraintP c i (PackageConstraintSource _) r
+ | not (instI i) = r
+ | otherwise = Fail c GlobalConstraintSource
+processPackageConstraintP _ _ _ r = r
+
+-- | Helper function that tries to enforce a single package constraint on a
+-- given flag setting for an F-node. Translates the constraint into a
+-- tree-transformer that either leaves the subtree untouched, or replaces it
+-- with an appropriate failure node.
+processPackageConstraintF :: Flag -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a
+processPackageConstraintF f c b' (PackageConstraintFlags _ fa) r =
+ case L.lookup f fa of
+ Nothing -> r
+ Just b | b == b' -> r
+ | otherwise -> Fail c GlobalConstraintFlag
+processPackageConstraintF _ _ _ _ r = r
-- | Traversal that tries to establish various kinds of user constraints. Works
-- by selectively disabling choices that have been rules out by global user
-- constraints.
-enforcePackageConstraints :: M.Map PN PackageConstraint -> Tree QGoalReasons -> Tree QGoalReasons
+enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasons -> Tree QGoalReasons
enforcePackageConstraints pcs = trav go
where
- go x@(PChoiceF qpn@(Q _ pn) gr ts) =
- let c = toConflictSet (Goal (P qpn) gr) in
- case M.lookup pn pcs of
- Just (PackageConstraintVersion _ vr) ->
- PChoiceF qpn gr
- (P.mapWithKey (\ (I v _) r -> if checkVR vr v
- then r
- else Fail c (GlobalConstraintVersion vr))
- ts)
- Just (PackageConstraintInstalled _) ->
- PChoiceF qpn gr
- (P.mapWithKey (\ i r -> if instI i
- then r
- else Fail c GlobalConstraintInstalled)
- ts)
- Just (PackageConstraintSource _) ->
- PChoiceF qpn gr
- (P.mapWithKey (\ i r -> if not (instI i)
- then r
- else Fail c GlobalConstraintSource)
- ts)
- _ -> x
- go x@(FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr ts) =
- let c = toConflictSet (Goal (F qfn) gr) in
- case M.lookup pn pcs of
- Just (PackageConstraintFlags _ fa) ->
- case L.lookup f fa of
- Nothing -> x
- Just b ->
- FChoiceF qfn gr tr
- (P.mapWithKey (\ b' r -> if b == b'
- then r
- else Fail c GlobalConstraintFlag)
- ts)
- _ -> x
+ go (PChoiceF qpn@(Q _ pn) gr ts) =
+ let c = toConflictSet (Goal (P qpn) gr)
+ -- compose the transformation functions for each of the relevant constraint
+ g = \ i -> foldl (\ h pc -> h . processPackageConstraintP c i pc) id
+ (M.findWithDefault [] pn pcs)
+ in PChoiceF qpn gr (P.mapWithKey g ts)
+ go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr ts) =
+ let c = toConflictSet (Goal (F qfn) gr)
+ -- compose the transformation functions for each of the relevant constraint
+ g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id
+ (M.findWithDefault [] pn pcs)
+ in FChoiceF qfn gr tr (P.mapWithKey g ts)
go x = x
-- | Prefer installed packages over non-installed packages, generally.
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
index 9ae783b..dc3b487 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -27,7 +27,7 @@ data SolverConfig = SolverConfig {
solve :: SolverConfig -> -- solver parameters
Index -> -- all available packages as an index
(PN -> PackagePreferences) -> -- preferences
- Map PN PackageConstraint -> -- global constraints
+ Map PN [PackageConstraint] -> -- global constraints
[PN] -> -- global goals
Log Message (Assignment, RevDepMap)
solve sc idx userPrefs userConstraints userGoals =
More information about the Cvs-libraries
mailing list