Commit 68695045 authored by Franz Thoma's avatar Franz Thoma
Browse files

Migrate ConflictSet qpn ↦ ConflictSet

parent 1b8f375a
......@@ -67,12 +67,12 @@ extend :: (Extension -> Bool) -- ^ is a given extension supported
-> (Language -> Bool) -- ^ is a given language supported
-> (PkgconfigName -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable
-> Var QPN
-> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
-> PPreAssignment -> [Dep QPN] -> Either (ConflictSet, [Dep QPN]) PPreAssignment
extend extSupported langSupported pkgPresent var = foldM extendSingle
where
extendSingle :: PPreAssignment -> Dep QPN
-> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
-> Either (ConflictSet, [Dep QPN]) PPreAssignment
extendSingle a (Ext ext ) =
if extSupported ext then Right a
else Left (varToConflictSet var, [Ext ext])
......
......@@ -48,9 +48,9 @@ import Distribution.Solver.Types.PackagePath
--
-- Since these variables should be preprocessed in some way, this type is
-- kept abstract.
data ConflictSet qpn = CS {
data ConflictSet = CS {
-- | The set of variables involved on the conflict
conflictSetToSet :: Set (Var qpn)
conflictSetToSet :: Set (Var QPN)
#ifdef DEBUG_CONFLICT_SETS
-- | The origin of the conflict set
......@@ -68,16 +68,16 @@ data ConflictSet qpn = CS {
}
deriving (Show)
instance Eq qpn => Eq (ConflictSet qpn) where
instance Eq ConflictSet where
(==) = (==) `on` conflictSetToSet
instance Ord qpn => Ord (ConflictSet qpn) where
instance Ord ConflictSet where
compare = compare `on` conflictSetToSet
showCS :: ConflictSet QPN -> String
showCS :: ConflictSet -> String
showCS = intercalate ", " . map showVar . toList
showCSWithFrequency :: ConflictMap -> ConflictSet QPN -> String
showCSWithFrequency :: ConflictMap -> ConflictSet -> String
showCSWithFrequency cm = intercalate ", " . map showWithFrequency . indexByFrequency
where
indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList
......@@ -89,14 +89,14 @@ showCSWithFrequency cm = intercalate ", " . map showWithFrequency . indexByFrequ
Set-like operations
-------------------------------------------------------------------------------}
toList :: ConflictSet qpn -> [Var qpn]
toList :: ConflictSet -> [Var QPN]
toList = S.toList . conflictSetToSet
union ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Ord qpn => ConflictSet qpn -> ConflictSet qpn -> ConflictSet qpn
ConflictSet -> ConflictSet -> ConflictSet
union cs cs' = CS {
conflictSetToSet = S.union (conflictSetToSet cs) (conflictSetToSet cs')
#ifdef DEBUG_CONFLICT_SETS
......@@ -108,7 +108,7 @@ unions ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Ord qpn => [ConflictSet qpn] -> ConflictSet qpn
[ConflictSet] -> ConflictSet
unions css = CS {
conflictSetToSet = S.unions (map conflictSetToSet css)
#ifdef DEBUG_CONFLICT_SETS
......@@ -120,7 +120,7 @@ insert ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn
Var QPN -> ConflictSet -> ConflictSet
insert var cs = CS {
conflictSetToSet = S.insert (simplifyVar var) (conflictSetToSet cs)
#ifdef DEBUG_CONFLICT_SETS
......@@ -132,7 +132,7 @@ empty ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
ConflictSet qpn
ConflictSet
empty = CS {
conflictSetToSet = S.empty
#ifdef DEBUG_CONFLICT_SETS
......@@ -144,7 +144,7 @@ singleton ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Var qpn -> ConflictSet qpn
Var QPN -> ConflictSet
singleton var = CS {
conflictSetToSet = S.singleton (simplifyVar var)
#ifdef DEBUG_CONFLICT_SETS
......@@ -152,17 +152,14 @@ singleton var = CS {
#endif
}
member :: Ord qpn => Var qpn -> ConflictSet qpn -> Bool
member :: Var QPN -> ConflictSet -> Bool
member var = S.member (simplifyVar var) . conflictSetToSet
filter ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
#if !MIN_VERSION_containers(0,5,0)
Ord qpn =>
#endif
(Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn
(Var QPN -> Bool) -> ConflictSet -> ConflictSet
filter p cs = CS {
conflictSetToSet = S.filter p (conflictSetToSet cs)
#ifdef DEBUG_CONFLICT_SETS
......@@ -174,7 +171,7 @@ fromList ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Ord qpn => [Var qpn] -> ConflictSet qpn
[Var QPN] -> ConflictSet
fromList vars = CS {
conflictSetToSet = S.fromList (map simplifyVar vars)
#ifdef DEBUG_CONFLICT_SETS
......
......@@ -34,7 +34,7 @@ detectCyclesPhase = cata go
-- | Given the reverse dependency map from a 'Done' node in the tree, check
-- if the solution is cyclic. If it is, return the conflict set containing
-- all decisions that could potentially break the cycle.
findCycles :: RevDepMap -> Maybe (ConflictSet QPN)
findCycles :: RevDepMap -> Maybe ConflictSet
findCycles revDeps =
case cycles of
[] -> Nothing
......
......@@ -101,7 +101,7 @@ merge ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)
CI QPN -> CI QPN -> Either (ConflictSet, (CI QPN, CI QPN)) (CI QPN)
merge c@(Fixed i g1) d@(Fixed j g2)
| i == j = Right c
| otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, d))
......@@ -378,11 +378,11 @@ goalToVar (Goal v _) = v
--
-- NOTE: This is just a call to 'varToConflictSet' under the hood;
-- the 'GoalReason' is ignored.
goalVarToConflictSet :: Goal qpn -> ConflictSet qpn
goalVarToConflictSet :: Goal QPN -> ConflictSet
goalVarToConflictSet (Goal g _gr) = varToConflictSet g
-- | Compute a singleton conflict set from a 'Var'
varToConflictSet :: Var qpn -> ConflictSet qpn
varToConflictSet :: Var QPN -> ConflictSet
varToConflictSet = CS.singleton
-- | A goal reason is mostly just a variable paired with the
......
......@@ -45,28 +45,28 @@ import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts
-- variable. See also the comments for 'avoidSet'.
--
backjump :: EnableBackjumping -> Var QPN
-> ConflictSet QPN -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a)
-> ConflictSet -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a)
-> ConflictMap -> ConflictSetLog a
backjump (EnableBackjumping enableBj) var initial xs =
F.foldr combine logBackjump xs initial
where
combine :: forall a . (ConflictMap -> ConflictSetLog a)
-> (ConflictSet QPN -> ConflictMap -> ConflictSetLog a)
-> ConflictSet QPN -> ConflictMap -> ConflictSetLog a
-> (ConflictSet -> ConflictMap -> ConflictSetLog a)
-> ConflictSet -> ConflictMap -> ConflictSetLog a
combine x f csAcc cm = retry (x cm) next
where
next :: (ConflictSet QPN, ConflictMap) -> ConflictSetLog a
next :: (ConflictSet, ConflictMap) -> ConflictSetLog a
next (cs, cm')
| enableBj && not (var `CS.member` cs) = logBackjump cs cm'
| otherwise = f (csAcc `CS.union` cs) cm'
logBackjump :: ConflictSet QPN -> ConflictMap -> ConflictSetLog a
logBackjump :: ConflictSet -> ConflictMap -> ConflictSetLog a
logBackjump cs !cm = failWith (Failure cs Backjump) (cs, updateCM initial cm)
-- 'intial' instead of 'cs' here ---^
-- since we do not want to double-count the
-- additionally accumulated conflicts.
type ConflictSetLog = RetryLog Message (ConflictSet QPN, ConflictMap)
type ConflictSetLog = RetryLog Message (ConflictSet, ConflictMap)
getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a)
getBestGoal cm =
......@@ -81,7 +81,7 @@ getFirstGoal ts =
(error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error
(\ k v _xs -> (k, v)) -- commit to the first goal choice
updateCM :: ConflictSet QPN -> ConflictMap -> ConflictMap
updateCM :: ConflictSet -> ConflictMap -> ConflictMap
updateCM cs cm =
L.foldl' (\ cmc k -> M.alter inc k cmc) cm (CS.toList cs)
where
......@@ -163,7 +163,7 @@ exploreLog enableBj (CountConflicts countConflicts) t = cata go t M.empty
-- current variable, the goal reason of the current node will be added to the
-- conflict set.
--
avoidSet :: Var QPN -> QGoalReason -> ConflictSet QPN
avoidSet :: Var QPN -> QGoalReason -> ConflictSet
avoidSet var gr =
CS.fromList (var : goalReasonToVars gr)
......
......@@ -125,7 +125,7 @@ validateLinking index = (`runReader` initVS) . cata go
Updating the validation state
-------------------------------------------------------------------------------}
type Conflict = (ConflictSet QPN, String)
type Conflict = (ConflictSet, String)
newtype UpdateState a = UpdateState {
unUpdateState :: StateT ValidateState (Either Conflict) a
......@@ -425,7 +425,7 @@ data LinkGroup = LinkGroup {
-- | The set of variables that should be added to the conflict set if
-- something goes wrong with this link set (in addition to the members
-- of the link group itself)
, lgBlame :: ConflictSet QPN
, lgBlame :: ConflictSet
}
deriving (Show, Eq)
......@@ -495,7 +495,7 @@ lgMerge blame lg lg' = do
++ " and " ++ showLinkGroup lg'
)
lgConflictSet :: LinkGroup -> ConflictSet QPN
lgConflictSet :: LinkGroup -> ConflictSet
lgConflictSet lg =
CS.fromList (map aux (S.toList (lgMembers lg)))
`CS.union` lgBlame lg
......
......@@ -8,7 +8,6 @@ import Distribution.Client.Compat.Prelude
import Data.List as L
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Progress
import Distribution.Solver.Modular.Dependency
......@@ -21,7 +20,7 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS
-- Represents the progress of a computation lazily.
--
-- Parameterized over the type of actual messages and the final result.
type Log m a = Progress m (ConflictSet QPN, ConflictMap) a
type Log m a = Progress m (ConflictSet, ConflictMap) a
messages :: Progress step fail done -> [step]
messages = foldProgress (:) (const []) (const [])
......@@ -43,7 +42,7 @@ logToProgress mbj l = let
-- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates
-- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the
-- original result.
proc :: Maybe Int -> Log Message b -> Progress Message (Exhaustiveness, ConflictSet QPN, ConflictMap) b
proc :: Maybe Int -> Log Message b -> Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b
proc _ (Done x) = Done x
proc _ (Fail (cs, cm)) = Fail (Exhaustive, cs, cm)
proc mbj' (Step x@(Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _)))
......@@ -60,9 +59,9 @@ logToProgress mbj l = let
--
-- The third argument is the full log, ending with either the solution or the
-- exhaustiveness and final conflict set.
go :: Progress Message (Exhaustiveness, ConflictSet QPN, ConflictMap) b
-> Progress Message (Exhaustiveness, ConflictSet QPN, ConflictMap) b
-> Progress String (Exhaustiveness, ConflictSet QPN, ConflictMap) b
go :: Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b
-> Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b
-> Progress String (Exhaustiveness, ConflictSet, ConflictMap) b
-> Progress String String b
go ms (Step _ ns) (Step x xs) = Step x (go ms ns xs)
go ms r (Step x xs) = Step x (go ms r xs)
......
......@@ -27,7 +27,7 @@ data Message =
| TryS QSN Bool
| Next (Goal QPN)
| Success
| Failure (ConflictSet QPN) FailReason
| Failure ConflictSet FailReason
-- | Transforms the structured message type to actual messages (strings).
--
......@@ -88,7 +88,7 @@ showMessages p sl = go [] 0
showPackageGoal :: QPN -> QGoalReason -> String
showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr
showFailure :: ConflictSet QPN -> FailReason -> String
showFailure :: ConflictSet -> FailReason -> String
showFailure c fr = "fail" ++ showFR c fr
add :: Var QPN -> [Var QPN] -> [Var QPN]
......@@ -99,7 +99,7 @@ showMessages p sl = go [] 0
-> Int
-> QPN
-> [POption]
-> ConflictSet QPN
-> ConflictSet
-> FailReason
-> Progress Message a b
-> Progress String a b
......@@ -128,7 +128,7 @@ showGR (PDependency pi) = " (dependency of " ++ showPI pi ++ ")"
showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")"
showGR (SDependency qsn) = " (dependency of " ++ showQSNBool qsn True ++ ")"
showFR :: ConflictSet QPN -> FailReason -> String
showFR :: ConflictSet -> FailReason -> String
showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)"
showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")"
showFR _ CannotInstall = " (only already installed instances can be used)"
......
......@@ -147,7 +147,7 @@ preferPackageStanzaPreferences pcs = trav go
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
processPackageConstraintP :: PackagePath
-> ConflictSet QPN
-> ConflictSet
-> I
-> LabeledPackageConstraint
-> Tree d c
......@@ -175,7 +175,7 @@ processPackageConstraintP _ c i (LabeledPackageConstraint pc src) r = go i pc
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
processPackageConstraintF :: Flag
-> ConflictSet QPN
-> ConflictSet
-> Bool
-> LabeledPackageConstraint
-> Tree d c
......@@ -194,7 +194,7 @@ processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r = go pc
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
processPackageConstraintS :: OptionalStanza
-> ConflictSet QPN
-> ConflictSet
-> Bool
-> LabeledPackageConstraint
-> Tree d c
......
......@@ -211,7 +211,7 @@ instance GSimpleTree (Tree d QGoalReason) where
shortGR (SDependency nm) = showQSN nm
-- Show conflict set
goCS :: ConflictSet QPN -> String
goCS :: ConflictSet -> String
goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}"
#endif
......
......@@ -72,7 +72,7 @@ data Tree d c =
| Done RevDepMap d
-- | We failed to find a solution in this path through the tree
| Fail (ConflictSet QPN) FailReason
| Fail ConflictSet FailReason
deriving (Eq, Show)
-- | A package option is a package instance with an optional linking annotation
......@@ -122,7 +122,7 @@ data TreeF d c a =
| SChoiceF QSN c WeakOrTrivial (WeightedPSQ [Weight] Bool a)
| GoalChoiceF (PSQ (Goal QPN) a)
| DoneF RevDepMap d
| FailF (ConflictSet QPN) FailReason
| FailF ConflictSet FailReason
deriving (Functor, Foldable, Traversable)
out :: Tree d c -> TreeF d c (Tree d c)
......
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