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 <[email protected]> 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 = _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
