Permalink
Browse files

Store manual flag info in search tree.

  • Loading branch information...
1 parent 61bf038 commit 951607ef39e036c71a09ac203e96438040e83386 @kosmikus kosmikus committed May 31, 2012
@@ -104,8 +104,8 @@ build = ana go
-- that is indicated by the flag default.
--
-- TODO: Should we include the flag default in the tree?
- go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b _) t f) gr) }) =
- FChoiceF qfn (gr, sc) trivial (P.fromList (reorder b
+ go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m) t f) gr) }) =
+ FChoiceF qfn (gr, sc) trivial m (P.fromList (reorder b
[(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }),
(False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))
where
@@ -24,16 +24,16 @@ backjump = snd . cata go
where
go (FailF c fr) = (Just c, Fail c fr)
go (DoneF rdm ) = (Nothing, Done rdm)
- go (PChoiceF qpn _ ts) = (c, PChoice qpn c (P.fromList ts'))
+ go (PChoiceF qpn _ ts) = (c, PChoice qpn c (P.fromList ts'))
where
~(c, ts') = combine (P qpn) (P.toList ts) S.empty
- go (FChoiceF qfn _ b ts) = (c, FChoice qfn c b (P.fromList ts'))
+ go (FChoiceF qfn _ b m ts) = (c, FChoice qfn c b m (P.fromList ts'))
where
~(c, ts') = combine (F qfn) (P.toList ts) S.empty
- go (SChoiceF qsn _ b ts) = (c, SChoice qsn c b (P.fromList ts'))
+ go (SChoiceF qsn _ b ts) = (c, SChoice qsn c b (P.fromList ts'))
where
~(c, ts') = combine (S qsn) (P.toList ts) S.empty
- go (GoalChoiceF ts) = (c, GoalChoice (P.fromList ts'))
+ go (GoalChoiceF ts) = (c, GoalChoice (P.fromList ts'))
where
~(cs, ts') = unzip $ L.map (\ (k, (x, v)) -> (x, (k, v))) $ P.toList ts
c = case cs of [] -> Nothing
@@ -77,22 +77,22 @@ explore = cata go
where
go (FailF _ _) _ = A.empty
go (DoneF rdm) a = pure (a, rdm)
- go (PChoiceF qpn _ ts) (A pa fa sa) =
+ go (PChoiceF qpn _ ts) (A pa fa sa) =
asum $ -- try children in order,
P.mapWithKey -- when descending ...
(\ k r -> r (A (M.insert qpn k pa) fa sa)) $ -- record the pkg choice
ts
- go (FChoiceF qfn _ _ ts) (A pa fa sa) =
+ go (FChoiceF qfn _ _ _ ts) (A pa fa sa) =
asum $ -- try children in order,
P.mapWithKey -- when descending ...
(\ k r -> r (A pa (M.insert qfn k fa) sa)) $ -- record the flag choice
ts
- go (SChoiceF qsn _ _ ts) (A pa fa sa) =
+ go (SChoiceF qsn _ _ ts) (A pa fa sa) =
asum $ -- try children in order,
P.mapWithKey -- when descending ...
(\ k r -> r (A pa fa (M.insert qsn k sa))) $ -- record the flag choice
ts
- go (GoalChoiceF ts) a =
+ go (GoalChoiceF ts) a =
casePSQ ts A.empty -- empty goal choice is an internal error
(\ _k v _xs -> v a) -- commit to the first goal choice
@@ -102,28 +102,28 @@ exploreLog = cata go
where
go (FailF c fr) _ = failWith (Failure c fr)
go (DoneF rdm) a = succeedWith Success (a, rdm)
- go (PChoiceF qpn c ts) (A pa fa sa) =
+ go (PChoiceF qpn c ts) (A pa fa sa) =
backjumpInfo c $
asum $ -- try children in order,
P.mapWithKey -- when descending ...
(\ k r -> tryWith (TryP (PI qpn k)) $ -- log and ...
r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice
ts
- go (FChoiceF qfn c _ ts) (A pa fa sa) =
+ go (FChoiceF qfn c _ _ ts) (A pa fa sa) =
backjumpInfo c $
asum $ -- try children in order,
P.mapWithKey -- when descending ...
(\ k r -> tryWith (TryF qfn k) $ -- log and ...
r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice
ts
- go (SChoiceF qsn c _ ts) (A pa fa sa) =
+ go (SChoiceF qsn c _ ts) (A pa fa sa) =
backjumpInfo c $
asum $ -- try children in order,
P.mapWithKey -- when descending ...
(\ k r -> tryWith (TryS qsn k) $ -- log and ...
r (A pa fa (M.insert qsn k sa))) -- record the pkg choice
ts
- go (GoalChoiceF ts) a =
+ go (GoalChoiceF ts) a =
casePSQ ts
(failWith (Failure S.empty EmptyGoalChoice)) -- empty goal choice is an internal error
(\ k v _xs -> continueWith (Next (close k)) (v a)) -- commit to the first goal choice
@@ -108,24 +108,24 @@ processPackageConstraintS _ _ _ _ r = r
enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasons -> Tree QGoalReasons
enforcePackageConstraints pcs = trav go
where
- go (PChoiceF qpn@(Q _ pn) gr ts) =
+ 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) =
+ in PChoiceF qpn gr (P.mapWithKey g ts)
+ go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m 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 (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) =
+ in FChoiceF qfn gr tr m (P.mapWithKey g ts)
+ go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) =
let c = toConflictSet (Goal (S qsn) gr)
-- compose the transformation functions for each of the relevant constraint
g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id
(M.findWithDefault [] pn pcs)
- in SChoiceF qsn gr tr (P.mapWithKey g ts)
+ in SChoiceF qsn gr tr (P.mapWithKey g ts)
go x = x
-- | Prefer installed packages over non-installed packages, generally.
@@ -232,9 +232,9 @@ deferDefaultFlagChoices = trav go
go x = x
defer :: Tree a -> Tree a -> Ordering
- defer (FChoice _ _ True _) _ = GT
- defer _ (FChoice _ _ True _) = LT
- defer _ _ = EQ
+ defer (FChoice _ _ True _ _) _ = GT
+ defer _ (FChoice _ _ True _ _) = LT
+ defer _ _ = EQ
-- | Variant of 'preferEasyGoalChoices'.
--
@@ -14,10 +14,10 @@ import Distribution.Client.Dependency.Modular.Version
-- | Type of the search tree. Inlining the choice nodes for now.
data Tree a =
- PChoice QPN a (PSQ I (Tree a))
- | FChoice QFN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial
- | SChoice QSN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial
- | GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty
+ PChoice QPN a (PSQ I (Tree a))
+ | FChoice QFN a Bool Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial, second Bool whether it's manual
+ | SChoice QSN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial
+ | GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty
| Done RevDepMap
| Fail (ConflictSet QPN) FailReason
deriving (Eq, Show)
@@ -26,12 +26,12 @@ data Tree a =
-- dependencies introduced by this node.
instance Functor Tree where
- fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs)
- fmap f (FChoice qfn i b xs) = FChoice qfn (f i) b (fmap (fmap f) xs)
- fmap f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs)
- fmap f (GoalChoice xs) = GoalChoice (fmap (fmap f) xs)
- fmap _f (Done rdm ) = Done rdm
- fmap _f (Fail cs fr ) = Fail cs fr
+ fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs)
+ fmap f (FChoice qfn i b m xs) = FChoice qfn (f i) b m (fmap (fmap f) xs)
+ fmap f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs)
+ fmap f (GoalChoice xs) = GoalChoice (fmap (fmap f) xs)
+ fmap _f (Done rdm ) = Done rdm
+ fmap _f (Fail cs fr ) = Fail cs fr
data FailReason = InconsistentInitialConstraints
| Conflicting [Dep QPN]
@@ -52,52 +52,52 @@ data FailReason = InconsistentInitialConstraints
-- | Functor for the tree type.
data TreeF a b =
- PChoiceF QPN a (PSQ I b)
- | FChoiceF QFN a Bool (PSQ Bool b)
- | SChoiceF QSN a Bool (PSQ Bool b)
- | GoalChoiceF (PSQ OpenGoal b)
+ PChoiceF QPN a (PSQ I b)
+ | FChoiceF QFN a Bool Bool (PSQ Bool b)
+ | SChoiceF QSN a Bool (PSQ Bool b)
+ | GoalChoiceF (PSQ OpenGoal b)
| DoneF RevDepMap
| FailF (ConflictSet QPN) FailReason
out :: Tree a -> TreeF a (Tree a)
-out (PChoice p i ts) = PChoiceF p i ts
-out (FChoice p i b ts) = FChoiceF p i b ts
-out (SChoice p i b ts) = SChoiceF p i b ts
-out (GoalChoice ts) = GoalChoiceF ts
-out (Done x ) = DoneF x
-out (Fail c x ) = FailF c x
+out (PChoice p i ts) = PChoiceF p i ts
+out (FChoice p i b m ts) = FChoiceF p i b m ts
+out (SChoice p i b ts) = SChoiceF p i b ts
+out (GoalChoice ts) = GoalChoiceF ts
+out (Done x ) = DoneF x
+out (Fail c x ) = FailF c x
inn :: TreeF a (Tree a) -> Tree a
-inn (PChoiceF p i ts) = PChoice p i ts
-inn (FChoiceF p i b ts) = FChoice p i b ts
-inn (SChoiceF p i b ts) = SChoice p i b ts
-inn (GoalChoiceF ts) = GoalChoice ts
-inn (DoneF x ) = Done x
-inn (FailF c x ) = Fail c x
+inn (PChoiceF p i ts) = PChoice p i ts
+inn (FChoiceF p i b m ts) = FChoice p i b m ts
+inn (SChoiceF p i b ts) = SChoice p i b ts
+inn (GoalChoiceF ts) = GoalChoice ts
+inn (DoneF x ) = Done x
+inn (FailF c x ) = Fail c x
instance Functor (TreeF a) where
- fmap f (PChoiceF p i ts) = PChoiceF p i (fmap f ts)
- fmap f (FChoiceF p i b ts) = FChoiceF p i b (fmap f ts)
- fmap f (SChoiceF p i b ts) = SChoiceF p i b (fmap f ts)
- fmap f (GoalChoiceF ts) = GoalChoiceF (fmap f ts)
- fmap _ (DoneF x ) = DoneF x
- fmap _ (FailF c x ) = FailF c x
+ fmap f (PChoiceF p i ts) = PChoiceF p i (fmap f ts)
+ fmap f (FChoiceF p i b m ts) = FChoiceF p i b m (fmap f ts)
+ fmap f (SChoiceF p i b ts) = SChoiceF p i b (fmap f ts)
+ fmap f (GoalChoiceF ts) = GoalChoiceF (fmap f ts)
+ fmap _ (DoneF x ) = DoneF x
+ fmap _ (FailF c x ) = FailF c x
instance Foldable (TreeF a) where
- foldr op e (PChoiceF _ _ ts) = foldr op e ts
- foldr op e (FChoiceF _ _ _ ts) = foldr op e ts
- foldr op e (SChoiceF _ _ _ ts) = foldr op e ts
- foldr op e (GoalChoiceF ts) = foldr op e ts
- foldr _ e (DoneF _ ) = e
- foldr _ e (FailF _ _ ) = e
+ foldr op e (PChoiceF _ _ ts) = foldr op e ts
+ foldr op e (FChoiceF _ _ _ _ ts) = foldr op e ts
+ foldr op e (SChoiceF _ _ _ ts) = foldr op e ts
+ foldr op e (GoalChoiceF ts) = foldr op e ts
+ foldr _ e (DoneF _ ) = e
+ foldr _ e (FailF _ _ ) = e
instance Traversable (TreeF a) where
- traverse f (PChoiceF p i ts) = PChoiceF <$> pure p <*> pure i <*> traverse f ts
- traverse f (FChoiceF p i b ts) = FChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts
- traverse f (SChoiceF p i b ts) = SChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts
- traverse f (GoalChoiceF ts) = GoalChoiceF <$> traverse f ts
- traverse _ (DoneF x ) = DoneF <$> pure x
- traverse _ (FailF c x ) = FailF <$> pure c <*> pure x
+ traverse f (PChoiceF p i ts) = PChoiceF <$> pure p <*> pure i <*> traverse f ts
+ traverse f (FChoiceF p i b m ts) = FChoiceF <$> pure p <*> pure i <*> pure b <*> pure m <*> traverse f ts
+ traverse f (SChoiceF p i b ts) = SChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts
+ traverse f (GoalChoiceF ts) = GoalChoiceF <$> traverse f ts
+ traverse _ (DoneF x ) = DoneF <$> pure x
+ traverse _ (FailF c x ) = FailF <$> pure c <*> pure x
-- | Determines whether a tree is active, i.e., isn't a failure node.
active :: Tree a -> Bool
@@ -107,22 +107,22 @@ active _ = True
-- | Determines how many active choices are available in a node. Note that we
-- count goal choices as having one choice, always.
choices :: Tree a -> Int
-choices (PChoice _ _ ts) = P.length (P.filter active ts)
-choices (FChoice _ _ _ ts) = P.length (P.filter active ts)
-choices (SChoice _ _ _ ts) = P.length (P.filter active ts)
-choices (GoalChoice _ ) = 1
-choices (Done _ ) = 1
-choices (Fail _ _ ) = 0
+choices (PChoice _ _ ts) = P.length (P.filter active ts)
+choices (FChoice _ _ _ _ ts) = P.length (P.filter active ts)
+choices (SChoice _ _ _ ts) = P.length (P.filter active ts)
+choices (GoalChoice _ ) = 1
+choices (Done _ ) = 1
+choices (Fail _ _ ) = 0
-- | Variant of 'choices' that only approximates the number of choices,
-- using 'llength'.
lchoices :: Tree a -> Int
-lchoices (PChoice _ _ ts) = P.llength (P.filter active ts)
-lchoices (FChoice _ _ _ ts) = P.llength (P.filter active ts)
-lchoices (SChoice _ _ _ ts) = P.llength (P.filter active ts)
-lchoices (GoalChoice _ ) = 1
-lchoices (Done _ ) = 1
-lchoices (Fail _ _ ) = 0
+lchoices (PChoice _ _ ts) = P.llength (P.filter active ts)
+lchoices (FChoice _ _ _ _ ts) = P.llength (P.filter active ts)
+lchoices (SChoice _ _ _ ts) = P.llength (P.filter active ts)
+lchoices (GoalChoice _ ) = 1
+lchoices (Done _ ) = 1
+lchoices (Fail _ _ ) = 0
-- | Catamorphism on trees.
cata :: (TreeF a b -> b) -> Tree a -> b
@@ -85,8 +85,8 @@ validate = cata go
where
go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons)
- go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)
- go (FChoiceF qfn (gr, _sc) b ts) =
+ go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)
+ go (FChoiceF qfn (gr, _sc) b m ts) =
do
-- Flag choices may occur repeatedly (because they can introduce new constraints
-- in various places). However, subsequent choices must be consistent. We thereby
@@ -98,8 +98,8 @@ validate = cata go
Just t -> goF qfn gr rb t
Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn)
Nothing -> -- flag choice is new, follow both branches
- FChoice qfn gr b <$> sequence (P.mapWithKey (goF qfn gr) ts)
- go (SChoiceF qsn (gr, _sc) b ts) =
+ FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn gr) ts)
+ go (SChoiceF qsn (gr, _sc) b ts) =
do
-- Optional stanza choices are very similar to flag choices.
PA _ _ psa <- asks pa -- obtain current stanza-preassignment

0 comments on commit 951607e

Please sign in to comment.