Permalink
Browse files

Make modular solver handle manual flags properly.

  • Loading branch information...
1 parent 951607e commit 235c7ce37e4405e3139d24af56e86882646f5be0 @kosmikus kosmikus committed May 31, 2012
@@ -87,6 +87,7 @@ showFR _ (GlobalConstraintVersion vr) = " (global constraint requires " ++ dis
showFR _ GlobalConstraintInstalled = " (global constraint requires installed instance)"
showFR _ GlobalConstraintSource = " (global constraint requires source instance)"
showFR _ GlobalConstraintFlag = " (global constraint requires opposite flag selection)"
+showFR _ ManualFlag = " (manual flag can only be changed explicitly)"
showFR _ (BuildFailureNotInIndex pn) = " (unknown package: " ++ display pn ++ ")"
showFR c Backjump = " (backjumping, conflict set: " ++ showCS c ++ ")"
-- The following are internal failures. They should not occur. In the
@@ -128,6 +128,23 @@ enforcePackageConstraints pcs = trav go
in SChoiceF qsn gr tr (P.mapWithKey g ts)
go x = x
+-- | Transformation that tries to enforce manual flags. Manual flags
+-- can only be re-set explicitly by the user. This transformation should
+-- be run after user preferences have been enforced. For manual flags,
+-- it disables all but the first non-disabled choice.
+enforceManualFlags :: Tree QGoalReasons -> Tree QGoalReasons
+enforceManualFlags = trav go
+ where
+ go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $
+ let c = toConflictSet (Goal (F qfn) gr)
+ in case span isDisabled (P.toList ts) of
+ (_ , []) -> P.fromList []
+ (xs, y : ys) -> P.fromList (xs ++ y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys)
+ where
+ isDisabled (_, Fail _ _) = True
+ isDisabled _ = False
+ go x = x
+
-- | Prefer installed packages over non-installed packages, generally.
-- All installed packages or non-installed packages are treated as
-- equivalent.
@@ -43,7 +43,8 @@ solve sc idx userPrefs userConstraints userGoals =
then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices
else P.preferBaseGoalChoice
preferencesPhase = P.preferPackagePreferences userPrefs
- validationPhase = P.enforcePackageConstraints userConstraints .
+ validationPhase = P.enforceManualFlags . -- can only be done after user constraints
+ P.enforcePackageConstraints userConstraints .
validateTree idx
prunePhase = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) .
-- packages that can never be "upgraded":
@@ -43,6 +43,7 @@ data FailReason = InconsistentInitialConstraints
| GlobalConstraintInstalled
| GlobalConstraintSource
| GlobalConstraintFlag
+ | ManualFlag
| BuildFailureNotInIndex PN
| MalformedFlagChoice QFN
| MalformedStanzaChoice QSN

0 comments on commit 235c7ce

Please sign in to comment.