Commit 47332566 authored by kristenk's avatar kristenk
Browse files

Add 'WeightedPSQ' and use it to sort package, flag, and stanza choices.

parent 15dbcaf6
......@@ -27,6 +27,7 @@ import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.PSQ (PSQ)
import qualified Distribution.Solver.Modular.PSQ as P
import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.WeightedPSQ as W
import Distribution.Solver.Types.ComponentDeps (Component)
import Distribution.Solver.Types.PackagePath
......@@ -134,9 +135,9 @@ build = ana go
-- We will probably want to give this case special treatment when generating error
-- messages though.
case M.lookup pn idx of
Nothing -> PChoiceF qpn gr (P.fromList [])
Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->
(POption i Nothing, bs { next = Instance qpn i info gr }))
Nothing -> PChoiceF qpn gr (W.fromList [])
Just pis -> PChoiceF qpn gr (W.fromList (L.map (\ (i, info) ->
([], POption i Nothing, bs { next = Instance qpn i info gr }))
(M.toList pis)))
-- TODO: data structure conversion is rather ugly here
......@@ -145,12 +146,10 @@ build = ana go
--
-- TODO: Should we include the flag default in the tree?
go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
FChoiceF qfn gr weak m (P.fromList (reorder b
[(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),
(False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })]))
FChoiceF qfn gr weak m (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
reorder True = id
reorder False = reverse
trivial = L.null t && L.null f
weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
......@@ -160,9 +159,9 @@ build = ana go
-- (try enabling the stanza if possible by moving the True branch first).
go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
SChoiceF qsn gr trivial (P.fromList
[(False, bs { next = Goals }),
(True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
SChoiceF qsn gr trivial (W.fromList
[([0], False, bs { next = Goals }),
([1], True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
where
trivial = WeakOrTrivial (L.null t)
......
......@@ -16,6 +16,7 @@ import qualified Distribution.Solver.Modular.PSQ as P
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Modular.RetryLog
import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.WeightedPSQ as W
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..))
......@@ -43,7 +44,7 @@ import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts
-- variable. See also the comments for 'avoidSet'.
--
backjump :: EnableBackjumping -> Var QPN
-> ConflictSet QPN -> P.PSQ k (ConflictMap -> ConflictSetLog a)
-> ConflictSet QPN -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a)
-> ConflictMap -> ConflictSetLog a
backjump (EnableBackjumping enableBj) var initial xs =
F.foldr combine logBackjump xs initial
......@@ -105,7 +106,7 @@ exploreLog enableBj (CountConflicts countConflicts) = cata go
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,
P.mapWithKey -- when descending ...
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
......@@ -113,7 +114,7 @@ exploreLog enableBj (CountConflicts countConflicts) = cata go
ts
go (FChoiceF qfn gr _ _ ts) (A pa fa sa) =
backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,
P.mapWithKey -- when descending ...
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
......@@ -121,7 +122,7 @@ exploreLog enableBj (CountConflicts countConflicts) = cata go
ts
go (SChoiceF qsn gr _ ts) (A pa fa sa) =
backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,
P.mapWithKey -- when descending ...
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
......
......@@ -29,8 +29,8 @@ import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Index
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.PSQ as P
import qualified Distribution.Solver.Modular.ConflictSet as CS
import qualified Distribution.Solver.Modular.WeightedPSQ as W
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
......@@ -69,9 +69,9 @@ addLinking = (`runReader` M.empty) . cata go
-- The only nodes of interest are package nodes
go (PChoiceF qpn gr cs) = do
env <- ask
let linkedCs = P.fromList $ concatMap (linkChoices env qpn) (P.toList cs)
unlinkedCs = P.mapWithKey (goP qpn) cs
allCs <- T.sequence $ unlinkedCs `P.union` linkedCs
let linkedCs = W.fromList $ concatMap (linkChoices env qpn) (W.toList cs)
unlinkedCs = W.mapWithKey (goP qpn) cs
allCs <- T.sequence $ unlinkedCs `W.union` linkedCs
return $ PChoice qpn gr allCs
go _otherwise =
innM _otherwise
......@@ -82,13 +82,16 @@ addLinking = (`runReader` M.empty) . cata go
goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp])
goP _ _ = alreadyLinked
linkChoices :: forall a . RelatedGoals -> QPN -> (POption, a) -> [(POption, a)]
linkChoices related (Q _pp pn) (POption i Nothing, subtree) =
linkChoices :: forall a w . RelatedGoals
-> QPN
-> (w, POption, a)
-> [(w, POption, a)]
linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) =
map aux (M.findWithDefault [] (pn, i) related)
where
aux :: PackagePath -> (POption, a)
aux pp = (POption i (Just pp), subtree)
linkChoices _ _ (POption _ (Just _), _) =
aux :: PackagePath -> (w, POption, a)
aux pp = (weight, POption i (Just pp), subtree)
linkChoices _ _ (_, POption _ (Just _), _) =
alreadyLinked
alreadyLinked :: a
......@@ -140,11 +143,11 @@ validateLinking index = (`runReader` initVS) . cata go
go :: TreeF a (Validate (Tree a)) -> Validate (Tree a)
go (PChoiceF qpn gr cs) =
PChoice qpn gr <$> T.sequence (P.mapWithKey (goP qpn) cs)
PChoice qpn gr <$> T.sequence (W.mapWithKey (goP qpn) cs)
go (FChoiceF qfn gr t m cs) =
FChoice qfn gr t m <$> T.sequence (P.mapWithKey (goF qfn) cs)
FChoice qfn gr t m <$> T.sequence (W.mapWithKey (goF qfn) cs)
go (SChoiceF qsn gr t cs) =
SChoice qsn gr t <$> T.sequence (P.mapWithKey (goS qsn) cs)
SChoice qsn gr t <$> T.sequence (W.mapWithKey (goS qsn) cs)
-- For the other nodes we just recurse
go (GoalChoiceF cs) = GoalChoice <$> T.sequence cs
......
......@@ -22,12 +22,12 @@ import Data.Function (on)
import qualified Data.List as L
import qualified Data.Map as M
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
import Control.Applicative
#endif
import Prelude hiding (sequence)
import Control.Monad.Reader hiding (sequence)
import Data.Map (Map)
import Data.Maybe (fromJust)
import Data.Traversable (sequence)
import Distribution.Solver.Types.ConstraintSource
......@@ -46,71 +46,94 @@ import qualified Distribution.Solver.Modular.PSQ as P
import Distribution.Solver.Modular.Tree
import Distribution.Solver.Modular.Version
import qualified Distribution.Solver.Modular.ConflictSet as CS
import qualified Distribution.Solver.Modular.WeightedPSQ as W
-- | Generic abstraction for strategies that just rearrange the package order.
-- Only packages that match the given predicate are reordered.
packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a
packageOrderFor p cmp' = trav go
-- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a
-- list of weight-calculating functions in order to avoid sorting the package
-- choices multiple times.
addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree a -> Tree a
addWeights fs = trav go
where
go (PChoiceF v@(Q _ pn) r cs)
| p pn = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs)
| otherwise = PChoiceF v r cs
go (PChoiceF qpn@(Q _ pn) x cs) =
-- TODO: Inputs to 'f' shouldn't depend on the node's position in the
-- tree. If we continue using a list of all versions as an input, it
-- should come from the package index, not from the node's siblings.
let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs)
weights k = [f pn sortedVersions k | f <- fs]
in PChoiceF qpn x $
W.mapWeightsWithKey (\k w -> weights k ++ w) cs
go x = x
cmp :: PN -> POption -> POption -> Ordering
cmp pn (POption i _) (POption i' _) = cmp' pn i i'
-- | Prefer to link packages whenever possible
addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree a -> Tree a
addWeight f = addWeights [f]
version :: POption -> Ver
version (POption (I v _) _) = v
-- | Prefer to link packages whenever possible.
-- TODO: I'm not sure how to handle the linking preference. It is tricky because
-- the set of available linking choices depends on goal order, yet we need
-- to ensure that goal order does not affect the overall install plan score.
-- Additionally, giving linked and unlinked packages different scores doesn't
-- seem quite right. Without the Single Instance Restriction, choosing to not
-- link a package doesn't necessarily give a different install plan than
-- linking the package. The solver could happen to make the same exact choices
-- for the unlinked package as the package that it could have been linked to.
-- At least the accidental linking can't happen as long as the solver always
-- prefers to link.
--
-- An implementation that adds a constant penalty to non-linked choices might
-- work, because every path that the solver could follow through the search tree
-- to find a given install plan should involve the same total number of link
-- choices. 'preferLinked' would add the same penalty along each path.
preferLinked :: Tree a -> Tree a
preferLinked = trav go
where
go (PChoiceF qn a cs) = PChoiceF qn a (P.sortByKeys cmp cs)
go x = x
cmp (POption _ linkedTo) (POption _ linkedTo') = cmpL linkedTo linkedTo'
cmpL Nothing Nothing = EQ
cmpL Nothing (Just _) = GT
cmpL (Just _) Nothing = LT
cmpL (Just _) (Just _) = EQ
-- | Ordering that treats versions satisfying more preferred ranges as greater
-- than versions satisfying less preferred ranges.
preferredVersionsOrdering :: [VR] -> Ver -> Ver -> Ordering
preferredVersionsOrdering vrs v1 v2 = compare (check v1) (check v2)
preferLinked = addWeight (const (const linked))
where
check v = Prelude.length . Prelude.filter (==True) .
Prelude.map (flip checkVR v) $ vrs
linked (POption _ Nothing) = 1
linked (POption _ (Just _)) = 0
-- | Traversal that tries to establish package preferences (not constraints).
-- Works by reordering choice nodes. Also applies stanza preferences.
-- Works by setting weights on choice nodes. Also applies stanza preferences.
preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a
preferPackagePreferences pcs = preferPackageStanzaPreferences pcs
. packageOrderFor (const True) preference
preferPackagePreferences pcs =
preferPackageStanzaPreferences pcs .
addWeights [
\pn _ opt -> preferred pn opt
-- Note that we always rank installed before uninstalled, and later
-- versions before earlier, but we can change the priority of the
-- two orderings.
, \pn vs opt -> case preference pn of
PreferInstalled -> installed opt
PreferLatest -> latest vs opt
, \pn vs opt -> case preference pn of
PreferInstalled -> latest vs opt
PreferLatest -> installed opt
]
where
preference pn i1@(I v1 _) i2@(I v2 _) =
let PackagePreferences vrs ipref _ = pcs pn
in preferredVersionsOrdering vrs v1 v2 `mappend` -- combines lexically
locationsOrdering ipref i1 i2
-- Note that we always rank installed before uninstalled, and later
-- versions before earlier, but we can change the priority of the
-- two orderings.
locationsOrdering PreferInstalled v1 v2 =
preferInstalledOrdering v1 v2 `mappend` preferLatestOrdering v1 v2
locationsOrdering PreferLatest v1 v2 =
preferLatestOrdering v1 v2 `mappend` preferInstalledOrdering v1 v2
-- | Ordering that treats installed instances as greater than uninstalled ones.
preferInstalledOrdering :: I -> I -> Ordering
preferInstalledOrdering (I _ (Inst _)) (I _ (Inst _)) = EQ
preferInstalledOrdering (I _ (Inst _)) _ = GT
preferInstalledOrdering _ (I _ (Inst _)) = LT
preferInstalledOrdering _ _ = EQ
-- | Compare instances by their version numbers.
preferLatestOrdering :: I -> I -> Ordering
preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2
-- Prefer packages with higher version numbers over packages with
-- lower version numbers.
latest :: [Ver] -> POption -> Weight
latest sortedVersions opt =
-- TODO: We should probably score versions based on their release dates.
let index = fromJust $ L.elemIndex (version opt) sortedVersions
in fromIntegral index / L.genericLength sortedVersions
preference :: PN -> InstalledPreference
preference pn =
let PackagePreferences _ ipref _ = pcs pn
in ipref
-- | Prefer versions satisfying more preferred version ranges.
preferred :: PN -> POption -> Weight
preferred pn opt =
let PackagePreferences vrs _ _ = pcs pn
in fromIntegral . negate . L.length $
L.filter (flip checkVR (version opt)) vrs
-- Prefer installed packages over non-installed packages.
installed :: POption -> Weight
installed (POption (I _ (Inst _)) _) = 0
installed _ = 1
-- | Traversal that tries to establish package stanza enable\/disable
-- preferences. Works by reordering the branches of stanza choices.
......@@ -120,7 +143,8 @@ preferPackageStanzaPreferences pcs = trav go
go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) gr _tr ts)
| primaryPP pp && enableStanzaPref pn s =
-- move True case first to try enabling the stanza
let ts' = P.sortByKeys (flip compare) ts
let ts' = W.mapWeightsWithKey (\k w -> score k : w) ts
score k = if k then 0 else 1
-- defer the choice by setting it to weak
in SChoiceF qsn gr (WeakOrTrivial True) ts'
go x = x
......@@ -207,19 +231,19 @@ enforcePackageConstraints pcs = trav go
-- compose the transformation functions for each of the relevant constraint
g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP pp c i pc) id
(M.findWithDefault [] pn pcs)
in PChoiceF qpn gr (P.mapWithKey g ts)
in PChoiceF qpn gr (W.mapWithKey g ts)
go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) =
let c = varToConflictSet (F qfn)
-- 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 m (P.mapWithKey g ts)
in FChoiceF qfn gr tr m (W.mapWithKey g ts)
go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) 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 f c b pc) id
(M.findWithDefault [] pn pcs)
in SChoiceF qsn gr tr (P.mapWithKey g ts)
in SChoiceF qsn gr tr (W.mapWithKey g ts)
go x = x
-- | Transformation that tries to enforce manual flags. Manual flags
......@@ -232,12 +256,12 @@ enforceManualFlags = trav go
where
go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $
let c = varToConflictSet (F qfn)
in case span isDisabled (P.toList ts) of
([], y : ys) -> P.fromList (y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys)
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
isDisabled (_, _, Fail _ (GlobalConstraintFlag _)) = True
isDisabled _ = False
go x = x
-- | Require installed packages.
......@@ -245,7 +269,7 @@ requireInstalled :: (PN -> Bool) -> Tree a -> Tree a
requireInstalled p = trav go
where
go (PChoiceF v@(Q _ pn) gr cs)
| p pn = PChoiceF v gr (P.mapWithKey installed cs)
| p pn = PChoiceF v gr (W.mapWithKey installed cs)
| otherwise = PChoiceF v gr cs
where
installed (POption (I _ (Inst _)) _) x = x
......@@ -273,8 +297,8 @@ avoidReinstalls p = trav go
| otherwise = PChoiceF qpn gr cs
where
disableReinstalls =
let installed = [ v | (POption (I v (Inst _)) _, _) <- P.toList cs ]
in P.mapWithKey (notReinstall installed) cs
let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ]
in W.mapWithKey (notReinstall installed) cs
notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =
Fail (varToConflictSet (P qpn)) CannotReinstall
......@@ -408,7 +432,7 @@ enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
-- We just verify package choices.
go (PChoiceF qpn gr cs) =
PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) cs)
PChoice qpn gr <$> sequence (W.mapWithKey (goP qpn) cs)
go _otherwise =
innM _otherwise
......
......@@ -42,6 +42,7 @@ import Distribution.Simple.Setup (BooleanFlag(..))
#ifdef DEBUG_TRACETREE
import Distribution.Solver.Modular.Flag
import qualified Distribution.Solver.Modular.ConflictSet as CS
import qualified Distribution.Solver.Modular.WeightedPSQ as W
import Debug.Trace.Tree (gtraceJson)
import Debug.Trace.Tree.Simple
......@@ -186,13 +187,16 @@ instance GSimpleTree (Tree QGoalReason) where
fromGeneric = go
where
go :: Tree QGoalReason -> SimpleTree
go (PChoice qpn _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ PSQ.toList psq
go (FChoice _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ PSQ.toList psq
go (SChoice _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ PSQ.toList psq
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 (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 _ (POption (I ver _loc) Nothing) subtree = (showVersion ver, go subtree)
......
......@@ -4,6 +4,7 @@ module Distribution.Solver.Modular.Tree
, POption(..)
, Tree(..)
, TreeF(..)
, Weight
, ana
, cata
, choices
......@@ -26,21 +27,25 @@ import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.PSQ (PSQ)
import qualified Distribution.Solver.Modular.PSQ as P
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.PackagePath
type Weight = Double
-- | Type of the search tree. Inlining the choice nodes for now.
data Tree a =
-- | Choose a version for a package (or choose to link)
PChoice QPN a (PSQ POption (Tree a))
PChoice QPN a (WeightedPSQ [Weight] POption (Tree a))
-- | Choose a value for a flag
--
-- The Bool indicates whether it's manual.
| FChoice QFN a WeakOrTrivial Bool (PSQ Bool (Tree a))
| FChoice QFN a WeakOrTrivial Bool (WeightedPSQ [Weight] Bool (Tree a))
-- | Choose whether or not to enable a stanza
| SChoice QSN a WeakOrTrivial (PSQ Bool (Tree a))
| SChoice QSN a WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree a))
-- | Choose which choice to make next
--
......@@ -103,9 +108,9 @@ data FailReason = InconsistentInitialConstraints
-- | Functor for the tree type.
data TreeF a b =
PChoiceF QPN a (PSQ POption b)
| FChoiceF QFN a WeakOrTrivial Bool (PSQ Bool b)
| SChoiceF QSN a WeakOrTrivial (PSQ Bool 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
| FailF (ConflictSet QPN) FailReason
......@@ -143,27 +148,27 @@ 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 (PChoice _ _ ts) = W.length (W.filter active ts)
choices (FChoice _ _ _ _ ts) = W.length (W.filter active ts)
choices (SChoice _ _ _ ts) = W.length (W.filter active ts)
choices (GoalChoice _ ) = 1
choices (Done _ ) = 1
choices (Fail _ _ ) = 0
-- | Variant of 'choices' that only approximates the number of choices.
dchoices :: Tree a -> P.Degree
dchoices (PChoice _ _ ts) = P.degree (P.filter active ts)
dchoices (FChoice _ _ _ _ ts) = P.degree (P.filter active ts)
dchoices (SChoice _ _ _ ts) = P.degree (P.filter active ts)
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 _ ) = P.ZeroOrOne
dchoices (Done _ ) = P.ZeroOrOne
dchoices (Fail _ _ ) = P.ZeroOrOne
-- | Variant of 'choices' that only approximates the number of choices.
zeroOrOneChoices :: Tree a -> Bool
zeroOrOneChoices (PChoice _ _ ts) = P.isZeroOrOne (P.filter active ts)
zeroOrOneChoices (FChoice _ _ _ _ ts) = P.isZeroOrOne (P.filter active ts)
zeroOrOneChoices (SChoice _ _ _ ts) = P.isZeroOrOne (P.filter active ts)
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
......
......@@ -25,9 +25,9 @@ import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Index
import Distribution.Solver.Modular.Package
import qualified Distribution.Solver.Modular.PSQ as P
import Distribution.Solver.Modular.Tree
import Distribution.Solver.Modular.Version (VR)
import qualified Distribution.Solver.Modular.WeightedPSQ as W
import Distribution.Solver.Types.ComponentDeps (Component)
......@@ -106,7 +106,7 @@ validate = cata go
where
go :: TreeF a (Validate (Tree a)) -> Validate (Tree a)
go (PChoiceF qpn gr ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) ts)
go (PChoiceF qpn gr ts) = PChoice qpn gr <$> sequence (W.mapWithKey (goP qpn) ts)
go (FChoiceF qfn gr b m ts) =
do
-- Flag choices may occur repeatedly (because they can introduce new constraints
......@@ -115,22 +115,22 @@ validate = cata go
PA _ pfa _ <- asks pa -- obtain current flag-preassignment
case M.lookup qfn pfa of
Just rb -> -- flag has already been assigned; collapse choice to the correct branch
case P.lookup rb ts of
case W.lookup rb ts of
Just t -> goF qfn rb t
Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn)
Nothing -> -- flag choice is new, follow both branches
FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn) ts)
FChoice qfn gr b m <$> sequence (W.mapWithKey (goF qfn) ts)
go (SChoiceF qsn gr b ts) =
do
-- Optional stanza choices are very similar to flag choices.
PA _ _ psa <- asks pa -- obtain current stanza-preassignment
case M.lookup qsn psa of
Just rb -> -- stanza choice has already been made; collapse choice to the correct branch
case P.lookup rb ts of
case W.lookup rb ts of
Just t -> goS qsn rb t
Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn)
Nothing -> -- stanza choice is new, follow both branches
SChoice qsn gr b <$> sequence (P.mapWithKey (goS qsn) ts)
SChoice qsn gr b <$> sequence (W.mapWithKey (goS qsn) ts)
-- We don't need to do anything for goal choices or failure nodes.
go (GoalChoiceF ts) = GoalChoice <$> sequence ts
......
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
module Distribution.Solver.Modular.WeightedPSQ (
WeightedPSQ
, filter
, fromList
, keys
, length
, degree
, isZeroOrOne
, lookup