Commit f7f63ab4 authored by kristenk's avatar kristenk Committed by Mikhail Glushenkov
Browse files

Allow the solver to toggle manual flags to match constraints that have any qualifier.

This fixes #4299. The change gives the dependency solver the flexibility to link
dependencies when the user has only set a manual flag on one of them.
Previously, the solver would force the constrained dependency to have the
flag value from the constraint and force the unconstrained dependency to have
the default flag value. In cases where the single instance restriction required
the dependencies to be linked, the solver couldn't find a solution.

Qualified constraints can still be used to force different dependencies on a
package to use different flag values. For example,
"--constraint 'pkg +flag' --constraint 'pkg2:setup.pkg -flag'" turns the flag on
for the top-level dependency and off for the setup dependency.

I also stored flag default values in the search tree to simplify the code.
parent 9098fac6
......@@ -160,10 +160,8 @@ addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (OpenGoal (Simple
-- For a flag, we create only two subtrees, and we create them in the order
-- that is indicated by the flag default.
--
-- TODO: Should we include the flag default in the tree?
addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
FChoiceF qfn rdm gr weak m (W.fromList
FChoiceF qfn rdm gr weak m b (W.fromList
[([if b then 0 else 1], True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),
([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })])
where
......
......@@ -23,21 +23,21 @@ detectCyclesPhase = cata go
where
-- Only check children of choice nodes.
go :: TreeF d c (Tree d c) -> Tree d c
go (PChoiceF qpn rdm gr cs) =
PChoice qpn rdm gr $ fmap (checkChild qpn) cs
go (FChoiceF qfn@(FN (PI qpn _) _) rdm gr w m cs) =
FChoice qfn rdm gr w m $ fmap (checkChild qpn) cs
go (SChoiceF qsn@(SN (PI qpn _) _) rdm gr w cs) =
SChoice qsn rdm gr w $ fmap (checkChild qpn) cs
go x = inn x
go (PChoiceF qpn rdm gr cs) =
PChoice qpn rdm gr $ fmap (checkChild qpn) cs
go (FChoiceF qfn@(FN (PI qpn _) _) rdm gr w m d cs) =
FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs
go (SChoiceF qsn@(SN (PI qpn _) _) rdm gr w cs) =
SChoice qsn rdm gr w $ fmap (checkChild qpn) cs
go x = inn x
checkChild :: QPN -> Tree d c -> Tree d c
checkChild qpn x@(PChoice _ rdm _ _) = failIfCycle qpn rdm x
checkChild qpn x@(FChoice _ rdm _ _ _ _) = failIfCycle qpn rdm x
checkChild qpn x@(SChoice _ rdm _ _ _) = failIfCycle qpn rdm x
checkChild qpn x@(GoalChoice rdm _) = failIfCycle qpn rdm x
checkChild _ x@(Fail _ _) = x
checkChild qpn x@(Done rdm _) = failIfCycle qpn rdm x
checkChild qpn x@(PChoice _ rdm _ _) = failIfCycle qpn rdm x
checkChild qpn x@(FChoice _ rdm _ _ _ _ _) = failIfCycle qpn rdm x
checkChild qpn x@(SChoice _ rdm _ _ _) = failIfCycle qpn rdm x
checkChild qpn x@(GoalChoice rdm _) = failIfCycle qpn rdm x
checkChild _ x@(Fail _ _) = x
checkChild qpn x@(Done rdm _) = failIfCycle qpn rdm x
failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c
failIfCycle qpn rdm x =
......
......@@ -94,15 +94,15 @@ assign tree = cata go tree $ A M.empty M.empty M.empty
where
go :: TreeF d c (Assignment -> Tree Assignment c)
-> (Assignment -> Tree Assignment c)
go (FailF c fr) _ = Fail c fr
go (DoneF rdm _) a = Done rdm a
go (PChoiceF qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f ts
go (FailF c fr) _ = Fail c fr
go (DoneF rdm _) a = Done rdm a
go (PChoiceF qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f ts
where f (POption k _) r = r (A (M.insert qpn k pa) fa sa)
go (FChoiceF qfn rdm y t m ts) (A pa fa sa) = FChoice qfn rdm y t m $ W.mapWithKey f ts
go (FChoiceF qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f ts
where f k r = r (A pa (M.insert qfn k fa) sa)
go (SChoiceF qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f ts
go (SChoiceF qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f ts
where f k r = r (A pa fa (M.insert qsn k sa))
go (GoalChoiceF rdm ts) a = GoalChoice rdm $ fmap ($ a) ts
go (GoalChoiceF rdm ts) a = GoalChoice rdm $ fmap ($ a) ts
-- | A tree traversal that simultaneously propagates conflict sets up
-- the tree from the leaves and creates a log.
......@@ -117,25 +117,25 @@ exploreLog enableBj (CountConflicts countConflicts) t = cata go t M.empty
go :: TreeF Assignment QGoalReason (ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
-> (ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
go (FailF c fr) = \ !cm -> failWith (Failure c fr)
go (FailF c fr) = \ !cm -> failWith (Failure c fr)
(c, updateCM c cm)
go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm)
go (PChoiceF qpn _ gr ts) =
go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm)
go (PChoiceF qpn _ gr ts) =
backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,
W.mapWithKey -- when descending ...
(\ k r cm -> tryWith (TryP qpn k) (r cm))
ts
go (FChoiceF qfn _ gr _ _ ts) =
go (FChoiceF qfn _ gr _ _ _ ts) =
backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,
W.mapWithKey -- when descending ...
(\ k r cm -> tryWith (TryF qfn k) (r cm))
ts
go (SChoiceF qsn _ gr _ ts) =
go (SChoiceF qsn _ gr _ ts) =
backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,
W.mapWithKey -- when descending ...
(\ k r cm -> tryWith (TryS qsn k) (r cm))
ts
go (GoalChoiceF _ ts) = \ cm ->
go (GoalChoiceF _ ts) = \ cm ->
let (k, v) = getBestGoal' ts cm
in continueWith (Next k) (v cm)
......
......@@ -22,6 +22,7 @@ import Prelude hiding (pi)
import Distribution.PackageDescription hiding (Flag) -- from Cabal
import Distribution.Solver.Modular.Package
import Distribution.Solver.Types.Flag
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
......@@ -41,8 +42,8 @@ mkFlag = mkFlagName
-- | Flag info. Default value, whether the flag is manual, and
-- whether the flag is weak. Manual flags can only be set explicitly.
-- Weak flags are typically deferred by the solver.
data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool, fweak :: WeakOrTrivial }
deriving (Eq, Ord, Show)
data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial }
deriving (Eq, Show)
-- | Flag defaults.
type FlagInfo = Map Flag FInfo
......
......@@ -25,6 +25,7 @@ import Distribution.System
import Distribution.Types.ForeignLib
import Distribution.Solver.Types.ComponentDeps (Component(..))
import Distribution.Solver.Types.Flag
import Distribution.Solver.Types.OptionalStanza
import qualified Distribution.Solver.Types.PackageIndex as CI
import Distribution.Solver.Types.Settings
......@@ -162,9 +163,10 @@ prefix f fds = [f (concat fds)]
-- unless strong flags have been selected explicitly.
flagInfo :: StrongFlags -> [PD.Flag] -> FlagInfo
flagInfo (StrongFlags strfl) =
M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (weak m)))
M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m)))
where
weak m = WeakOrTrivial $ not (strfl || m)
flagType m = if m then Manual else Automatic
-- | Internal package names, which should not be interpreted as true
-- dependencies.
......
......@@ -75,15 +75,15 @@ validateLinking index = (`runReader` initVS) . cata go
where
go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)
go (PChoiceF qpn rdm gr cs) =
PChoice qpn rdm gr <$> T.sequence (W.mapWithKey (goP qpn) cs)
go (FChoiceF qfn rdm gr t m cs) =
FChoice qfn rdm gr t m <$> T.sequence (W.mapWithKey (goF qfn) cs)
go (SChoiceF qsn rdm gr t cs) =
SChoice qsn rdm gr t <$> T.sequence (W.mapWithKey (goS qsn) cs)
go (PChoiceF qpn rdm gr cs) =
PChoice qpn rdm gr <$> T.sequence (W.mapWithKey (goP qpn) cs)
go (FChoiceF qfn rdm gr t m d cs) =
FChoice qfn rdm gr t m d <$> T.sequence (W.mapWithKey (goF qfn) cs)
go (SChoiceF qsn rdm gr t cs) =
SChoice qsn rdm gr t <$> T.sequence (W.mapWithKey (goS qsn) cs)
-- For the other nodes we just recurse
go (GoalChoiceF rdm cs) = GoalChoice rdm <$> T.sequence cs
go (GoalChoiceF rdm cs) = GoalChoice rdm <$> T.sequence cs
go (DoneF revDepMap s) = return $ Done revDepMap s
go (FailF conflictSet failReason) = return $ Fail conflictSet failReason
......
......@@ -25,6 +25,7 @@ import qualified Data.Map as M
import Control.Monad.Reader hiding (sequence)
import Data.Traversable (sequence)
import Distribution.Solver.Types.Flag
import Distribution.Solver.Types.InstalledPreference
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
......@@ -228,40 +229,66 @@ enforcePackageConstraints pcs = trav go
g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc)
id
(M.findWithDefault [] pn pcs)
in PChoiceF qpn rdm gr (W.mapWithKey g ts)
go (FChoiceF qfn@(FN (PI qpn@(Q _ pn) _) f) rdm gr tr m ts) =
in PChoiceF qpn rdm gr (W.mapWithKey g ts)
go (FChoiceF qfn@(FN (PI qpn@(Q _ pn) _) f) rdm gr tr m d ts) =
let c = varToConflictSet (F qfn)
-- compose the transformation functions for each of the relevant constraint
g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc)
id
(M.findWithDefault [] pn pcs)
in FChoiceF qfn rdm gr tr m (W.mapWithKey g ts)
in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts)
go (SChoiceF qsn@(SN (PI qpn@(Q _ pn) _) f) rdm gr tr ts) =
let c = varToConflictSet (S qsn)
-- compose the transformation functions for each of the relevant constraint
g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc)
id
(M.findWithDefault [] pn pcs)
in SChoiceF qsn rdm gr tr (W.mapWithKey g ts)
in SChoiceF qsn rdm gr tr (W.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 checks if a user choice has been made. If not, it disables all but
-- the first choice.
enforceManualFlags :: Tree d c -> Tree d c
enforceManualFlags = trav go
-- | Transformation that tries to enforce the rule that manual flags can only be
-- set by the user.
--
-- If there are no constraints on a manual flag, this function prunes all but
-- the default value. If there are constraints, then the flag is allowed to have
-- the values specified by the constraints. Note that the type used for flag
-- values doesn't need to be Bool.
--
-- This function makes an exception for the case where there are multiple goals
-- for a single package (with different qualifiers), and flag constraints for
-- manual flag x only apply to some of those goals. In that case, we allow the
-- unconstrained goals to use the default value for x OR any of the values in
-- the constraints on x (even though the constraints don't apply), in order to
-- allow the unconstrained goals to be linked to the constrained goals. See
-- https://github.com/haskell/cabal/issues/4299.
--
-- This function does not enforce any of the constraints, since that is done by
-- 'enforcePackageConstraints'.
enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c
enforceManualFlags pcs = trav go
where
go (FChoiceF qfn rdm gr tr True ts) = FChoiceF qfn rdm gr tr True $
let c = varToConflictSet (F qfn)
in case span isDisabled (W.toList ts) of
([], y : ys) -> W.fromList (y : L.map (\ (w, b, _) -> (w, b, Fail c ManualFlag)) ys)
_ -> ts -- something has been manually selected, leave things alone
where
isDisabled (_, _, Fail _ (GlobalConstraintFlag _)) = True
isDisabled _ = False
go x = x
go (FChoiceF qfn@(FN (PI (Q _ pn) _) fn) rdm gr tr Manual d ts) =
FChoiceF qfn rdm gr tr Manual d $
let -- A list of all values specified by constraints on 'fn',
-- regardless of scope.
flagConstraintValues :: [Bool]
flagConstraintValues =
[ flagVal
| let lpcs = M.findWithDefault [] pn pcs
, (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs
, (fn', flagVal) <- fa
, fn' == fn ]
-- Prune flag values that are not the default and do not match any
-- of the constraints.
restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c
restrictToggling flagDefault constraintVals flagVal r =
if flagVal `elem` constraintVals || flagVal == flagDefault
then r
else Fail (varToConflictSet (F qfn)) ManualFlag
in W.mapWithKey (restrictToggling d flagConstraintValues) ts
go x = x
-- | Require installed packages.
requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c
......@@ -369,12 +396,12 @@ deferWeakFlagChoices = trav go
go x = x
noWeakStanza :: Tree d c -> Bool
noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False
noWeakStanza _ = True
noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False
noWeakStanza _ = True
noWeakFlag :: Tree d c -> Bool
noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _) = False
noWeakFlag _ = True
noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False
noWeakFlag _ = True
-- | Transformation that prefers goals with lower branching degrees.
--
......
......@@ -111,8 +111,8 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
preferencesPhase = P.preferLinked .
P.preferPackagePreferences userPrefs
validationPhase = traceTree "validated.json" id .
P.enforceManualFlags . -- can only be done after user constraints
P.enforcePackageConstraints userConstraints .
P.enforceManualFlags userConstraints .
P.enforceSingleInstanceRestriction .
validateLinking idx .
validateTree cinfo idx pkgConfigDB
......@@ -174,12 +174,12 @@ instance GSimpleTree (Tree d c) where
fromGeneric = go
where
go :: Tree d c -> SimpleTree
go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq
go (FChoice _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq
go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq
go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq
go (Done _rdm _s) = Node "D" $ Assoc []
go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)]
go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq
go (FChoice _ _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq
go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq
go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq
go (Done _rdm _s) = Node "D" $ Assoc []
go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)]
psqToList :: W.WeightedPSQ w k v -> [(k, v)]
psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList
......@@ -219,12 +219,12 @@ _removeGR :: Tree d c -> Tree d QGoalReason
_removeGR = trav go
where
go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason)
go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq
go (FChoiceF qfn rdm _ a b psq) = FChoiceF qfn rdm dummy a b psq
go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq
go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq)
go (DoneF rdm s) = DoneF rdm s
go (FailF cs reason) = FailF cs reason
go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq
go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq
go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq
go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq)
go (DoneF rdm s) = DoneF rdm s
go (FailF cs reason) = FailF cs reason
goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason)
goG = PSQ.fromList
......
......@@ -27,6 +27,7 @@ import Distribution.Solver.Modular.Version
import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ)
import qualified Distribution.Solver.Modular.WeightedPSQ as W
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.Flag
import Distribution.Solver.Types.PackagePath
type Weight = Double
......@@ -47,8 +48,8 @@ data Tree d c =
-- | Choose a value for a flag
--
-- The Bool indicates whether it's manual.
| FChoice QFN RevDepMap c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool (Tree d c))
-- The Bool is the default value.
| FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c))
-- | Choose whether or not to enable a stanza
| SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c))
......@@ -115,37 +116,37 @@ data FailReason = InconsistentInitialConstraints
-- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c'
-- have the same meaning as in 'Tree'.
data TreeF d c a =
PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a)
| FChoiceF QFN RevDepMap c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool a)
| SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a)
| GoalChoiceF RevDepMap (PSQ (Goal QPN) a)
PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a)
| FChoiceF QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool a)
| SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a)
| GoalChoiceF RevDepMap (PSQ (Goal QPN) a)
| DoneF RevDepMap d
| FailF ConflictSet FailReason
deriving (Functor, Foldable, Traversable)
out :: Tree d c -> TreeF d c (Tree d c)
out (PChoice p s i ts) = PChoiceF p s i ts
out (FChoice p s i b m ts) = FChoiceF p s i b m ts
out (SChoice p s i b ts) = SChoiceF p s i b ts
out (GoalChoice s ts) = GoalChoiceF s ts
out (Done x s ) = DoneF x s
out (Fail c x ) = FailF c x
out (PChoice p s i ts) = PChoiceF p s i ts
out (FChoice p s i b m d ts) = FChoiceF p s i b m d ts
out (SChoice p s i b ts) = SChoiceF p s i b ts
out (GoalChoice s ts) = GoalChoiceF s ts
out (Done x s ) = DoneF x s
out (Fail c x ) = FailF c x
inn :: TreeF d c (Tree d c) -> Tree d c
inn (PChoiceF p s i ts) = PChoice p s i ts
inn (FChoiceF p s i b m ts) = FChoice p s i b m ts
inn (SChoiceF p s i b ts) = SChoice p s i b ts
inn (GoalChoiceF s ts) = GoalChoice s ts
inn (DoneF x s ) = Done x s
inn (FailF c x ) = Fail c x
inn (PChoiceF p s i ts) = PChoice p s i ts
inn (FChoiceF p s i b m d ts) = FChoice p s i b m d ts
inn (SChoiceF p s i b ts) = SChoice p s i b ts
inn (GoalChoiceF s ts) = GoalChoice s ts
inn (DoneF x s ) = Done x s
inn (FailF c x ) = Fail c x
innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c)
innM (PChoiceF p s i ts) = liftM (PChoice p s i ) (sequence ts)
innM (FChoiceF p s i b m ts) = liftM (FChoice p s i b m) (sequence ts)
innM (SChoiceF p s i b ts) = liftM (SChoice p s i b ) (sequence ts)
innM (GoalChoiceF s ts) = liftM (GoalChoice s ) (sequence ts)
innM (DoneF x s ) = return $ Done x s
innM (FailF c x ) = return $ Fail c x
innM (PChoiceF p s i ts) = liftM (PChoice p s i ) (sequence ts)
innM (FChoiceF p s i b m d ts) = liftM (FChoice p s i b m d) (sequence ts)
innM (SChoiceF p s i b ts) = liftM (SChoice p s i b ) (sequence ts)
innM (GoalChoiceF s ts) = liftM (GoalChoice s ) (sequence ts)
innM (DoneF x s ) = return $ Done x s
innM (FailF c x ) = return $ Fail c x
-- | Determines whether a tree is active, i.e., isn't a failure node.
active :: Tree d c -> Bool
......@@ -155,12 +156,12 @@ active _ = True
-- | Approximates the number of active choices that are available in a node.
-- Note that we count goal choices as having one choice, always.
zeroOrOneChoices :: Tree d c -> Bool
zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts)
zeroOrOneChoices (FChoice _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts)
zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts)
zeroOrOneChoices (GoalChoice _ _ ) = True
zeroOrOneChoices (Done _ _ ) = True
zeroOrOneChoices (Fail _ _ ) = True
zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts)
zeroOrOneChoices (FChoice _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts)
zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts)
zeroOrOneChoices (GoalChoice _ _ ) = True
zeroOrOneChoices (Done _ _ ) = True
zeroOrOneChoices (Fail _ _ ) = True
-- | Catamorphism on trees.
cata :: (TreeF d c a -> a) -> Tree d c -> a
......
......@@ -106,8 +106,8 @@ validate = cata go
where
go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)
go (PChoiceF qpn rdm gr ts) = PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) ts)
go (FChoiceF qfn rdm gr b m ts) =
go (PChoiceF qpn rdm gr ts) = PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) ts)
go (FChoiceF qfn rdm gr b m d ts) =
do
-- Flag choices may occur repeatedly (because they can introduce new constraints
-- in various places). However, subsequent choices must be consistent. We thereby
......@@ -119,7 +119,7 @@ validate = cata go
Just t -> goF qfn rb t
Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn)
Nothing -> -- flag choice is new, follow both branches
FChoice qfn rdm gr b m <$> sequence (W.mapWithKey (goF qfn) ts)
FChoice qfn rdm gr b m d <$> sequence (W.mapWithKey (goF qfn) ts)
go (SChoiceF qsn rdm gr b ts) =
do
-- Optional stanza choices are very similar to flag choices.
......@@ -133,9 +133,9 @@ validate = cata go
SChoice qsn rdm gr b <$> sequence (W.mapWithKey (goS qsn) ts)
-- We don't need to do anything for goal choices or failure nodes.
go (GoalChoiceF rdm ts) = GoalChoice rdm <$> sequence ts
go (DoneF rdm s ) = pure (Done rdm s)
go (FailF c fr ) = pure (Fail c fr)
go (GoalChoiceF rdm ts) = GoalChoice rdm <$> sequence ts
go (DoneF rdm s ) = pure (Done rdm s)
go (FailF c fr ) = pure (Fail c fr)
-- What to do for package nodes ...
goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
......
module Distribution.Solver.Types.Flag
( FlagType(..)
) where
data FlagType = Manual | Automatic
deriving (Eq, Show)
......@@ -304,6 +304,7 @@ library
Distribution.Solver.Types.ComponentDeps
Distribution.Solver.Types.ConstraintSource
Distribution.Solver.Types.DependencyResolver
Distribution.Solver.Types.Flag
Distribution.Solver.Types.InstalledPreference
Distribution.Solver.Types.InstSolverPackage
Distribution.Solver.Types.LabeledPackageConstraint
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment