Commit 6a4844b8 authored by Edward Z. Yang's avatar Edward Z. Yang Committed by GitHub
Browse files

Merge pull request #3820 from grayjay/done-node-field

Add a new field to solver Done nodes, and simplify Explore.exploreLog.
parents 4de99957 6b7c5367
......@@ -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
......
......@@ -86,52 +86,58 @@ updateCM cs cm =
inc Nothing = Just 1
inc (Just n) = Just $! n + 1
-- | Record complete assignments on 'Done' nodes.
assign :: Tree d c -> Tree Assignment c
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 y ts) (A pa fa sa) = PChoice qpn y $ W.mapWithKey f ts
where f (POption k _) r = r (A (M.insert qpn k pa) fa sa)
go (FChoiceF qfn y t m ts) (A pa fa sa) = FChoice qfn y t m $ W.mapWithKey f ts
where f k r = r (A pa (M.insert qfn k fa) sa)
go (SChoiceF qsn y t ts) (A pa fa sa) = SChoice qsn y t $ W.mapWithKey f ts
where f k r = r (A pa fa (M.insert qsn k sa))
go (GoalChoiceF ts) a = GoalChoice $ fmap ($ a) ts
-- | A tree traversal that simultaneously propagates conflict sets up
-- the tree from the leaves and creates a log.
exploreLog :: EnableBackjumping -> CountConflicts -> Tree QGoalReason
-> (Assignment -> ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
exploreLog enableBj (CountConflicts countConflicts) = cata go
exploreLog :: EnableBackjumping -> CountConflicts -> Tree Assignment QGoalReason
-> ConflictSetLog (Assignment, RevDepMap)
exploreLog enableBj (CountConflicts countConflicts) t = cata go t M.empty
where
getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a)
getBestGoal'
| countConflicts = \ ts cm -> getBestGoal cm ts
| otherwise = \ ts _ -> getFirstGoal ts
go :: TreeF QGoalReason (Assignment -> ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
-> (Assignment -> ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
go (FailF c fr) _ = \ cm -> let failure = failWith (Failure c fr)
go :: TreeF Assignment QGoalReason (ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
-> (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 (PChoiceF qpn gr ts) (A pa fa sa) =
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 ...
(\ i@(POption k _) r cm ->
let l = r (A (M.insert qpn k pa) fa sa) cm
in tryWith (TryP qpn i) l
)
ts
go (FChoiceF qfn gr _ _ ts) (A pa fa sa) =
(\ k r cm -> tryWith (TryP qpn k) (r cm))
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 ->
let l = r (A pa (M.insert qfn k fa) sa) cm
in tryWith (TryF qfn k) l
)
ts
go (SChoiceF qsn gr _ ts) (A pa fa sa) =
(\ k r cm -> tryWith (TryF qfn k) (r cm))
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 ->
let l = r (A pa fa (M.insert qsn k sa)) cm
in tryWith (TryS qsn k) l
)
ts
go (GoalChoiceF ts) a = \ cm ->
(\ k r cm -> tryWith (TryS qsn k) (r cm))
ts
go (GoalChoiceF ts) = \ cm ->
let (k, v) = getBestGoal' ts cm
l = v a cm
in continueWith (Next k) l
in continueWith (Next k) (v cm)
-- | Build a conflict set corresponding to the (virtual) option not to
-- choose a solution for a goal at all.
......@@ -164,9 +170,9 @@ avoidSet var gr =
-- | Interface.
backjumpAndExplore :: EnableBackjumping
-> CountConflicts
-> Tree QGoalReason -> Log Message (Assignment, RevDepMap)
backjumpAndExplore enableBj countConflicts t =
toLog $ exploreLog enableBj countConflicts t (A M.empty M.empty M.empty) M.empty
-> Tree d QGoalReason -> Log Message (Assignment, RevDepMap)
backjumpAndExplore enableBj countConflicts =
toLog . exploreLog enableBj countConflicts . assign
where
toLog :: RetryLog step fail done -> Log step done
toLog = toProgress . mapFailure (const ())
......@@ -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,14 +66,14 @@ 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
deriving (Eq, Show, Functor)
deriving (Eq, Show)
-- | A package option is a package instance with an optional linking annotation
--
......@@ -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