Commit 8c8fcc5e authored by kristenk's avatar kristenk
Browse files

Add a new field to solver Done nodes.

parent 01c28ea9
......@@ -103,16 +103,16 @@ data BuildType =
| Instance QPN I PInfo QGoalReason -- ^ build a tree for a concrete instance
deriving Show
build :: BuildState -> Tree QGoalReason
build :: BuildState -> Tree () QGoalReason
build = ana go
where
go :: BuildState -> TreeF QGoalReason BuildState
go :: BuildState -> TreeF () QGoalReason BuildState
-- If we have a choice between many goals, we just record the choice in
-- the tree. We select each open goal in turn, and before we descend, remove
-- it from the queue of open goals.
go bs@(BS { rdeps = rds, open = gs, next = Goals })
| P.null gs = DoneF rds
| P.null gs = DoneF rds ()
| otherwise = GoalChoiceF $ P.mapKeys close
$ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })
$ P.splits gs
......@@ -175,7 +175,7 @@ build = ana go
-- | Interface to the tree builder. Just takes an index and a list of package names,
-- and computes the initial state and then the tree from there.
buildTree :: Index -> IndependentGoals -> [PN] -> Tree QGoalReason
buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason
buildTree idx (IndependentGoals ind) igs =
build BS {
index = idx
......
......@@ -14,11 +14,11 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Types.PackagePath
-- | Find and reject any solutions that are cyclic
detectCyclesPhase :: Tree a -> Tree a
detectCyclesPhase :: Tree d c -> Tree d c
detectCyclesPhase = cata go
where
-- The only node of interest is DoneF
go :: TreeF a (Tree a) -> Tree a
go :: TreeF d c (Tree d c) -> Tree d c
go (PChoiceF qpn gr cs) = PChoice qpn gr cs
go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m cs
go (SChoiceF qsn gr w cs) = SChoice qsn gr w cs
......@@ -27,9 +27,9 @@ detectCyclesPhase = cata go
-- We check for cycles only if we have actually found a solution
-- This minimizes the number of cycle checks we do as cycles are rare
go (DoneF revDeps) = do
go (DoneF revDeps s) = do
case findCycles revDeps of
Nothing -> Done revDeps
Nothing -> Done revDeps s
Just relSet -> Fail relSet CyclicDependencies
-- | Given the reverse dependency map from a 'Done' node in the tree, check
......
......@@ -88,7 +88,7 @@ updateCM cs cm =
-- | A tree traversal that simultaneously propagates conflict sets up
-- the tree from the leaves and creates a log.
exploreLog :: EnableBackjumping -> CountConflicts -> Tree QGoalReason
exploreLog :: EnableBackjumping -> CountConflicts -> Tree d QGoalReason
-> (Assignment -> ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
exploreLog enableBj (CountConflicts countConflicts) = cata go
where
......@@ -97,13 +97,13 @@ exploreLog enableBj (CountConflicts countConflicts) = cata go
| countConflicts = \ ts cm -> getBestGoal cm ts
| otherwise = \ ts _ -> getFirstGoal ts
go :: TreeF QGoalReason (Assignment -> ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
-> (Assignment -> ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
go :: TreeF d QGoalReason (Assignment -> ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
-> (Assignment -> ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
go (FailF c fr) _ = \ cm -> let failure = failWith (Failure c fr)
in if countConflicts
then failure (c, updateCM c cm)
else failure (c, cm)
go (DoneF rdm) a = \ _ -> succeedWith Success (a, rdm)
go (DoneF rdm _) a = \ _ -> succeedWith Success (a, rdm)
go (PChoiceF qpn gr ts) (A pa fa sa) =
backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,
W.mapWithKey -- when descending ...
......@@ -164,7 +164,7 @@ avoidSet var gr =
-- | Interface.
backjumpAndExplore :: EnableBackjumping
-> CountConflicts
-> Tree QGoalReason -> Log Message (Assignment, RevDepMap)
-> Tree d QGoalReason -> Log Message (Assignment, RevDepMap)
backjumpAndExplore enableBj countConflicts t =
toLog $ exploreLog enableBj countConflicts t (A M.empty M.empty M.empty) M.empty
where
......
......@@ -61,10 +61,10 @@ type Linker = Reader RelatedGoals
-- package instance. Whenever we make an unlinked choice, we extend the map.
-- Whenever we find a choice, we look into the map in order to find out what
-- link options we have to add.
addLinking :: Tree a -> Tree a
addLinking :: Tree d c -> Tree d c
addLinking = (`runReader` M.empty) . cata go
where
go :: TreeF a (Linker (Tree a)) -> Linker (Tree a)
go :: TreeF d c (Linker (Tree d c)) -> Linker (Tree d c)
-- The only nodes of interest are package nodes
go (PChoiceF qpn gr cs) = do
......@@ -78,7 +78,7 @@ addLinking = (`runReader` M.empty) . cata go
-- Recurse underneath package choices. Here we just need to make sure
-- that we record the package choice so that it is available below
goP :: QPN -> POption -> Linker (Tree a) -> Linker (Tree a)
goP :: QPN -> POption -> Linker (Tree d c) -> Linker (Tree d c)
goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp])
goP _ _ = alreadyLinked
......@@ -137,10 +137,10 @@ type Validate = Reader ValidateState
-- * Linked dependencies,
-- * Equal flag assignments
-- * Equal stanza assignments
validateLinking :: Index -> Tree a -> Tree a
validateLinking :: Index -> Tree d c -> Tree d c
validateLinking index = (`runReader` initVS) . cata go
where
go :: TreeF a (Validate (Tree a)) -> Validate (Tree a)
go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)
go (PChoiceF qpn gr cs) =
PChoice qpn gr <$> T.sequence (W.mapWithKey (goP qpn) cs)
......@@ -151,11 +151,11 @@ validateLinking index = (`runReader` initVS) . cata go
-- For the other nodes we just recurse
go (GoalChoiceF cs) = GoalChoice <$> T.sequence cs
go (DoneF revDepMap) = return $ Done revDepMap
go (DoneF revDepMap s) = return $ Done revDepMap s
go (FailF conflictSet failReason) = return $ Fail conflictSet failReason
-- Package choices
goP :: QPN -> POption -> Validate (Tree a) -> Validate (Tree a)
goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
goP qpn@(Q _pp pn) opt@(POption i _) r = do
vs <- ask
let PInfo deps _ _ = vsIndex vs ! pn ! i
......@@ -165,7 +165,7 @@ validateLinking index = (`runReader` initVS) . cata go
Right vs' -> local (const vs') r
-- Flag choices
goF :: QFN -> Bool -> Validate (Tree a) -> Validate (Tree a)
goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goF qfn b r = do
vs <- ask
case execUpdateState (pickFlag qfn b) vs of
......@@ -173,7 +173,7 @@ validateLinking index = (`runReader` initVS) . cata go
Right vs' -> local (const vs') r
-- Stanza choices (much the same as flag choices)
goS :: QSN -> Bool -> Validate (Tree a) -> Validate (Tree a)
goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
goS qsn b r = do
vs <- ask
case execUpdateState (pickStanza qsn b) vs of
......
......@@ -54,10 +54,10 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W
-- children's versions, and package option. 'addWeights' prepends the new
-- weights to the existing weights, which gives precedence to preferences that
-- are applied later.
addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree a -> Tree a
addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree d c -> Tree d c
addWeights fs = trav go
where
go :: TreeF a (Tree a) -> TreeF a (Tree a)
go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)
go (PChoiceF qpn@(Q _ pn) x cs) =
let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs)
weights k = [f pn sortedVersions k | f <- fs]
......@@ -72,21 +72,21 @@ addWeights fs = trav go
W.mapWeightsWithKey (\k w -> weights k ++ w) cs)
go x = x
addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree a -> Tree a
addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree d c -> Tree d c
addWeight f = addWeights [f]
version :: POption -> Ver
version (POption (I v _) _) = v
-- | Prefer to link packages whenever possible.
preferLinked :: Tree a -> Tree a
preferLinked :: Tree d c -> Tree d c
preferLinked = addWeight (const (const linked))
where
linked (POption _ Nothing) = 1
linked (POption _ (Just _)) = 0
-- Works by setting weights on choice nodes. Also applies stanza preferences.
preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a
preferPackagePreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c
preferPackagePreferences pcs =
preferPackageStanzaPreferences pcs .
addWeights [
......@@ -130,7 +130,7 @@ preferPackagePreferences pcs =
-- | Traversal that tries to establish package stanza enable\/disable
-- preferences. Works by reordering the branches of stanza choices.
preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a
preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c
preferPackageStanzaPreferences pcs = trav go
where
go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) gr _tr ts)
......@@ -155,8 +155,8 @@ processPackageConstraintP :: PackagePath
-> ConflictSet QPN
-> I
-> LabeledPackageConstraint
-> Tree a
-> Tree a
-> Tree d c
-> Tree d c
processPackageConstraintP pp _ _ (LabeledPackageConstraint _ src) r
| src == ConstraintSourceUserTarget && not (primaryPP pp) = r
-- the constraints arising from targets, like "foo-1.0" only apply to
......@@ -183,8 +183,8 @@ processPackageConstraintF :: Flag
-> ConflictSet QPN
-> Bool
-> LabeledPackageConstraint
-> Tree a
-> Tree a
-> Tree d c
-> Tree d c
processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r = go pc
where
go (PackageConstraintFlags _ fa) =
......@@ -202,8 +202,8 @@ processPackageConstraintS :: OptionalStanza
-> ConflictSet QPN
-> Bool
-> LabeledPackageConstraint
-> Tree a
-> Tree a
-> Tree d c
-> Tree d c
processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc
where
go (PackageConstraintStanzas _ ss) =
......@@ -215,8 +215,8 @@ processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc
-- by selectively disabling choices that have been ruled out by global user
-- constraints.
enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]
-> Tree a
-> Tree a
-> Tree d c
-> Tree d c
enforcePackageConstraints pcs = trav go
where
go (PChoiceF qpn@(Q pp pn) gr ts) =
......@@ -244,7 +244,7 @@ enforcePackageConstraints pcs = trav go
-- 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 a -> Tree a
enforceManualFlags :: Tree d c -> Tree d c
enforceManualFlags = trav go
where
go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $
......@@ -258,7 +258,7 @@ enforceManualFlags = trav go
go x = x
-- | Require installed packages.
requireInstalled :: (PN -> Bool) -> Tree a -> Tree a
requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c
requireInstalled p = trav go
where
go (PChoiceF v@(Q _ pn) gr cs)
......@@ -282,7 +282,7 @@ requireInstalled p = trav go
-- they are, perhaps this should just result in trying to reinstall those other
-- packages as well. However, doing this all neatly in one pass would require to
-- change the builder, or at least to change the goal set after building.
avoidReinstalls :: (PN -> Bool) -> Tree a -> Tree a
avoidReinstalls :: (PN -> Bool) -> Tree d c -> Tree d c
avoidReinstalls p = trav go
where
go (PChoiceF qpn@(Q _ pn) gr cs)
......@@ -300,7 +300,7 @@ avoidReinstalls p = trav go
go x = x
-- | Sort all goals using the provided function.
sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree a -> Tree a
sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c
sortGoals variableOrder = trav go
where
go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys goalOrder xs)
......@@ -320,7 +320,7 @@ sortGoals variableOrder = trav go
-- This is unnecessary for the default search strategy, because
-- it descends only into the first goal choice anyway,
-- but may still make sense to just reduce the tree size a bit.
firstGoal :: Tree a -> Tree a
firstGoal :: Tree d c -> Tree d c
firstGoal = trav go
where
go (GoalChoiceF xs) = GoalChoiceF (P.firstOnly xs)
......@@ -330,7 +330,7 @@ firstGoal = trav go
-- | Transformation that tries to make a decision on base as early as
-- possible. In nearly all cases, there's a single choice for the base
-- package. Also, fixing base early should lead to better error messages.
preferBaseGoalChoice :: Tree a -> Tree a
preferBaseGoalChoice :: Tree d c -> Tree d c
preferBaseGoalChoice = trav go
where
go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys isBase xs)
......@@ -342,7 +342,7 @@ preferBaseGoalChoice = trav go
-- | Deal with setup dependencies after regular dependencies, so that we can
-- will link setup dependencies against package dependencies when possible
deferSetupChoices :: Tree a -> Tree a
deferSetupChoices :: Tree d c -> Tree d c
deferSetupChoices = trav go
where
go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys noSetup xs)
......@@ -355,17 +355,17 @@ deferSetupChoices = trav go
-- | Transformation that tries to avoid making weak flag choices early.
-- Weak flags are trivial flags (not influencing dependencies) or such
-- flags that are explicitly declared to be weak in the index.
deferWeakFlagChoices :: Tree a -> Tree a
deferWeakFlagChoices :: Tree d c -> Tree d c
deferWeakFlagChoices = trav go
where
go (GoalChoiceF xs) = GoalChoiceF (P.prefer noWeakStanza (P.prefer noWeakFlag xs))
go x = x
noWeakStanza :: Tree a -> Bool
noWeakStanza :: Tree d c -> Bool
noWeakStanza (SChoice _ _ (WeakOrTrivial True) _) = False
noWeakStanza _ = True
noWeakFlag :: Tree a -> Bool
noWeakFlag :: Tree d c -> Bool
noWeakFlag (FChoice _ _ (WeakOrTrivial True) _ _) = False
noWeakFlag _ = True
......@@ -387,7 +387,7 @@ deferWeakFlagChoices = trav go
--
-- Returns at most one choice.
--
preferEasyGoalChoices :: Tree a -> Tree a
preferEasyGoalChoices :: Tree d c -> Tree d c
preferEasyGoalChoices = trav go
where
go (GoalChoiceF xs) = GoalChoiceF (P.dminimumBy dchoices xs)
......@@ -400,7 +400,7 @@ preferEasyGoalChoices = trav go
-- 'preferEasyGoalChoices', this may return more than one
-- choice.
--
preferReallyEasyGoalChoices :: Tree a -> Tree a
preferReallyEasyGoalChoices :: Tree d c -> Tree d c
preferReallyEasyGoalChoices = trav go
where
go (GoalChoiceF xs) = GoalChoiceF (P.prefer zeroOrOneChoices xs)
......@@ -418,10 +418,10 @@ type EnforceSIR = Reader (Map (PI PN) QPN)
-- (that is, package name + package version) there can be at most one qualified
-- goal resolving to that instance (there may be other goals _linking_ to that
-- instance however).
enforceSingleInstanceRestriction :: Tree a -> Tree a
enforceSingleInstanceRestriction :: Tree d c -> Tree d c
enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
where
go :: TreeF a (EnforceSIR (Tree a)) -> EnforceSIR (Tree a)
go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c)
-- We just verify package choices.
go (PChoiceF qpn gr cs) =
......@@ -430,7 +430,7 @@ enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
innM _otherwise
-- The check proper
goP :: QPN -> POption -> EnforceSIR (Tree a) -> EnforceSIR (Tree a)
goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c)
goP qpn@(Q _ pn) (POption i linkedTo) r = do
let inst = PI pn i
env <- ask
......
......@@ -184,31 +184,31 @@ traceTree _ _ = id
#endif
#ifdef DEBUG_TRACETREE
instance GSimpleTree (Tree QGoalReason) where
instance GSimpleTree (Tree d QGoalReason) where
fromGeneric = go
where
go :: Tree QGoalReason -> SimpleTree
go :: Tree d QGoalReason -> 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) = Node "D" $ Assoc []
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
-- Show package choice
goP :: QPN -> POption -> Tree QGoalReason -> (String, SimpleTree)
goP :: QPN -> POption -> Tree d QGoalReason -> (String, SimpleTree)
goP _ (POption (I ver _loc) Nothing) subtree = (showVersion ver, go subtree)
goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree)
-- Show flag or stanza choice
goFS :: Bool -> Tree QGoalReason -> (String, SimpleTree)
goFS :: Bool -> Tree d QGoalReason -> (String, SimpleTree)
goFS val subtree = (show val, go subtree)
-- Show goal choice
goG :: Goal QPN -> Tree QGoalReason -> (String, SimpleTree)
goG :: Goal QPN -> Tree d QGoalReason -> (String, SimpleTree)
goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree)
-- Variation on 'showGR' that produces shorter strings
......@@ -229,18 +229,18 @@ instance GSimpleTree (Tree QGoalReason) where
-- | Replace all goal reasons with a dummy goal reason in the tree
--
-- This is useful for debugging (when experimenting with the impact of GRs)
_removeGR :: Tree QGoalReason -> Tree QGoalReason
_removeGR :: Tree d QGoalReason -> Tree d QGoalReason
_removeGR = trav go
where
go :: TreeF QGoalReason (Tree QGoalReason) -> TreeF QGoalReason (Tree QGoalReason)
go :: TreeF d QGoalReason (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason)
go (PChoiceF qpn _ psq) = PChoiceF qpn dummy psq
go (FChoiceF qfn _ a b psq) = FChoiceF qfn dummy a b psq
go (SChoiceF qsn _ a psq) = SChoiceF qsn dummy a psq
go (GoalChoiceF psq) = GoalChoiceF (goG psq)
go (DoneF rdm) = DoneF rdm
go (DoneF rdm s) = DoneF rdm s
go (FailF cs reason) = FailF cs reason
goG :: PSQ (Goal QPN) (Tree QGoalReason) -> PSQ (Goal QPN) (Tree QGoalReason)
goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason)
goG = PSQ.fromList
. L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree))
. PSQ.toList
......
......@@ -35,19 +35,25 @@ type Weight = Double
-- | Type of the search tree. Inlining the choice nodes for now. Weights on
-- package, flag, and stanza choices control the traversal order.
--
-- The tree can hold additional data on 'Done' nodes (type 'd') and choice nodes
-- (type 'c'). For example, during the final traversal, choice nodes contain the
-- variables that introduced the choices, and 'Done' nodes contain the
-- assignments for all variables.
--
-- TODO: The weight type should be changed from [Double] to Double to avoid
-- giving too much weight to preferences that are applied later.
data Tree a =
data Tree d c =
-- | Choose a version for a package (or choose to link)
PChoice QPN a (WeightedPSQ [Weight] POption (Tree a))
PChoice QPN c (WeightedPSQ [Weight] POption (Tree d c))
-- | Choose a value for a flag
--
-- The Bool indicates whether it's manual.
| FChoice QFN a WeakOrTrivial Bool (WeightedPSQ [Weight] Bool (Tree a))
| FChoice QFN c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool (Tree d c))
-- | Choose whether or not to enable a stanza
| SChoice QSN a WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree a))
| SChoice QSN c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c))
-- | Choose which choice to make next
--
......@@ -60,10 +66,10 @@ data Tree a =
-- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice'
-- or 'SChoice' directly below a 'GoalChoice' node must equal the reason
-- recorded on that 'GoalChoice' node.
| GoalChoice (PSQ (Goal QPN) (Tree a))
| GoalChoice (PSQ (Goal QPN) (Tree d c))
-- | We're done -- we found a solution!
| Done RevDepMap
| Done RevDepMap d
-- | We failed to find a solution in this path through the tree
| Fail (ConflictSet QPN) FailReason
......@@ -108,75 +114,76 @@ data FailReason = InconsistentInitialConstraints
| CyclicDependencies
deriving (Eq, Show)
-- | Functor for the tree type.
data TreeF a b =
PChoiceF QPN a (WeightedPSQ [Weight] POption b)
| FChoiceF QFN a WeakOrTrivial Bool (WeightedPSQ [Weight] Bool b)
| SChoiceF QSN a WeakOrTrivial (WeightedPSQ [Weight] Bool b)
| GoalChoiceF (PSQ (Goal QPN) b)
| DoneF RevDepMap
-- | 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 c (WeightedPSQ [Weight] POption a)
| FChoiceF QFN c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool a)
| SChoiceF QSN c WeakOrTrivial (WeightedPSQ [Weight] Bool a)
| GoalChoiceF (PSQ (Goal QPN) a)
| DoneF RevDepMap d
| FailF (ConflictSet QPN) FailReason
deriving (Functor, Foldable, Traversable)
out :: Tree a -> TreeF a (Tree a)
out :: Tree d c -> TreeF d c (Tree d c)
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 (Done x s ) = DoneF x s
out (Fail c x ) = FailF c x
inn :: TreeF a (Tree a) -> Tree a
inn :: TreeF d c (Tree d c) -> Tree d c
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 (DoneF x s ) = Done x s
inn (FailF c x ) = Fail c x
innM :: Monad m => TreeF a (m (Tree a)) -> m (Tree a)
innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c)
innM (PChoiceF p i ts) = liftM (PChoice p i ) (sequence ts)
innM (FChoiceF p i b m ts) = liftM (FChoice p i b m) (sequence ts)
innM (SChoiceF p i b ts) = liftM (SChoice p i b ) (sequence ts)
innM (GoalChoiceF ts) = liftM (GoalChoice ) (sequence ts)
innM (DoneF x ) = return $ Done x
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 a -> Bool
active :: Tree d c -> Bool
active (Fail _ _) = False
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.
dchoices :: Tree a -> Degree
dchoices :: Tree d c -> Degree
dchoices (PChoice _ _ ts) = W.degree (W.filter active ts)
dchoices (FChoice _ _ _ _ ts) = W.degree (W.filter active ts)
dchoices (SChoice _ _ _ ts) = W.degree (W.filter active ts)
dchoices (GoalChoice _ ) = ZeroOrOne
dchoices (Done _ ) = ZeroOrOne
dchoices (Done _ _ ) = ZeroOrOne
dchoices (Fail _ _ ) = ZeroOrOne
-- | Variant of 'dchoices' that traverses fewer children.
zeroOrOneChoices :: Tree a -> Bool
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 (Done _ _ ) = True
zeroOrOneChoices (Fail _ _ ) = True
-- | Catamorphism on trees.
cata :: (TreeF a b -> b) -> Tree a -> b
cata :: (TreeF d c a -> a) -> Tree d c -> a
cata phi x = (phi . fmap (cata phi) . out) x
trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b
trav :: (TreeF d c (Tree d a) -> TreeF d a (Tree d a)) -> Tree d c -> Tree d a
trav psi x = cata (inn . psi) x
-- | Paramorphism on trees.
para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b
para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a
para phi = phi . fmap (\ x -> (para phi x, x)) . out
-- | Anamorphism on trees.
ana :: (b -> TreeF a b) -> b -> Tree a
ana :: (a -> TreeF d c a) -> a -> Tree d c
ana psi = inn . fmap (ana psi) . psi
......@@ -101,10 +101,10 @@ newtype Validate a = Validate (Reader ValidateState a)
runValidate :: Validate a -> ValidateState -> a