Commit 16cae8a0 authored by Andres Löh's avatar Andres Löh
Browse files

Replace Goal with Var where possible; remove Unknown goal reason.

In several places where we used to work with Goals mainly to maintain
the goal reasons for constructing conflict sets, we can now do so
without, and just use Vars instead.

This also has the advantage that when creating dependencies during
index conversion, we now do not have to invent goal reasons. We used
to do that by having an "Unknown" goal reason. This is now no longer
necessary.
parent 018e9365
......@@ -90,9 +90,9 @@ extend extSupported langSupported pkgPresent var = foldM extendSingle
-- making a choice pkg == instance, and pkg => pkg == instance is a part
-- of the conflict, then this info is clear from the context and does not
-- have to be repeated.
simplify v (Fixed _ (Goal var' _)) c | v == var && var' == var = [c]
simplify v c (Fixed _ (Goal var' _)) | v == var && var' == var = [c]
simplify _ c d = [c, d]
simplify v (Fixed _ var') c | v == var && var' == var = [c]
simplify v c (Fixed _ var') | v == var && var' == var = [c]
simplify _ c d = [c, d]
-- | Delivers an ordered list of fully configured packages.
--
......
......@@ -29,7 +29,7 @@ module Distribution.Client.Dependency.Modular.Dependency (
, Goal(..)
, GoalReason(..)
, QGoalReason
, ResetGoal(..)
, ResetVar(..)
, goalVarToConflictSet
, varToConflictSet
, goalReasonToVars
......@@ -64,7 +64,7 @@ import Distribution.Client.ComponentDeps (Component(..))
-- a fixed instance, and we record the package name for which the choice
-- is for convenience. Otherwise, it is a list of version ranges paired with
-- the goals / variables that introduced them.
data CI qpn = Fixed I (Goal qpn) | Constrained [VROrigin qpn]
data CI qpn = Fixed I (Var qpn) | Constrained [VROrigin qpn]
deriving (Eq, Show, Functor)
showCI :: CI QPN -> String
......@@ -88,13 +88,13 @@ showCI (Constrained vr) = showVR (collapse vr)
merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)
merge c@(Fixed i g1) d@(Fixed j g2)
| i == j = Right c
| otherwise = Left (CS.union (goalVarToConflictSet g1) (goalVarToConflictSet g2), (c, d))
| otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, d))
merge c@(Fixed (I v _) g1) (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...
where
go [] = Right c
go (d@(vr, g2) : vrs)
| checkVR vr v = go vrs
| otherwise = Left (CS.union (goalVarToConflictSet g1) (goalVarToConflictSet g2), (c, Constrained [d]))
| otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, Constrained [d]))
merge c@(Constrained _) d@(Fixed _ _) = merge d c
merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss))
......@@ -164,12 +164,12 @@ data Dep qpn = Dep qpn (CI qpn) -- dependency on a package
deriving (Eq, Show)
showDep :: Dep QPN -> String
showDep (Dep qpn (Fixed i (Goal v _)) ) =
showDep (Dep qpn (Fixed i v) ) =
(if P qpn /= v then showVar v ++ " => " else "") ++
showQPN qpn ++ "==" ++ showI i
showDep (Dep qpn (Constrained [(vr, Goal v _)])) =
showDep (Dep qpn (Constrained [(vr, v)])) =
showVar v ++ " => " ++ showQPN qpn ++ showVR vr
showDep (Dep qpn ci ) =
showDep (Dep qpn ci ) =
showQPN qpn ++ showCI ci
showDep (Ext ext) = "requires " ++ display ext
showDep (Lang lang) = "requires " ++ display lang
......@@ -324,7 +324,6 @@ data Goal qpn = Goal (Var qpn) (GoalReason qpn)
-- | Reason why a goal is being added to a goal set.
data GoalReason qpn =
UserGoal
| Unknown -- TODO: is this really needed?
| PDependency (PI qpn)
| FDependency (FN qpn) Bool
| SDependency (SN qpn)
......@@ -332,21 +331,21 @@ data GoalReason qpn =
type QGoalReason = GoalReason QPN
class ResetGoal f where
resetGoal :: Goal qpn -> f qpn -> f qpn
class ResetVar f where
resetVar :: Var qpn -> f qpn -> f qpn
instance ResetGoal CI where
resetGoal g (Fixed i _) = Fixed i g
resetGoal g (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetGoal g y)) vrs)
instance ResetVar CI where
resetVar v (Fixed i _) = Fixed i v
resetVar v (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetVar v y)) vrs)
instance ResetGoal Dep where
resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)
resetGoal _ (Ext ext) = Ext ext
resetGoal _ (Lang lang) = Lang lang
resetGoal _ (Pkg pn vr) = Pkg pn vr
instance ResetVar Dep where
resetVar v (Dep qpn ci) = Dep qpn (resetVar v ci)
resetVar _ (Ext ext) = Ext ext
resetVar _ (Lang lang) = Lang lang
resetVar _ (Pkg pn vr) = Pkg pn vr
instance ResetGoal Goal where
resetGoal = const
instance ResetVar Var where
resetVar = const
-- | Compute a singleton conflict set from a goal, containing just
-- the goal variable.
......@@ -371,7 +370,6 @@ goalReasonToVars UserGoal = []
goalReasonToVars (PDependency (PI qpn _)) = [P qpn]
goalReasonToVars (FDependency qfn _) = [F qfn]
goalReasonToVars (SDependency qsn) = [S qsn]
goalReasonToVars Unknown = []
{-------------------------------------------------------------------------------
Open goals
......@@ -399,7 +397,7 @@ close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr
Version ranges paired with origins
-------------------------------------------------------------------------------}
type VROrigin qpn = (VR, Goal qpn)
type VROrigin qpn = (VR, Var qpn)
-- | Helper function to collapse a list of version ranges with origins into
-- a single, simplified, version range.
......
......@@ -84,7 +84,7 @@ convIPId pn' idx ipid =
Nothing -> Nothing
Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)
pn = pkgName (sourcePackageId ipi)
in Just (D.Simple (Dep pn (Fixed i (Goal (P pn') Unknown))) ())
in Just (D.Simple (Dep pn (Fixed i (P pn'))) ())
-- | Convert a cabal-install source package index to the simpler,
-- more uniform index format of the solver.
......@@ -300,7 +300,7 @@ convBranch os arch cinfo pi@(PI pn _) fds comp getInfo ipns (c', t', mf') =
-- occurrences of multiple version ranges, as all dependencies below this
-- point have been generated using 'convDep'.
extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN
extractCommon ps ps' = [ D.Simple (Dep pn1 (Constrained [(vr1 .||. vr2, Goal (P pn) Unknown)])) comp
extractCommon ps ps' = [ D.Simple (Dep pn1 (Constrained [(vr1 .||. vr2, P pn)])) comp
| D.Simple (Dep pn1 (Constrained [(vr1, _)])) _ <- ps
, D.Simple (Dep pn2 (Constrained [(vr2, _)])) _ <- ps'
, pn1 == pn2
......@@ -308,7 +308,7 @@ convBranch os arch cinfo pi@(PI pn _) fds comp getInfo ipns (c', t', mf') =
-- | Convert a Cabal dependency to a solver-specific dependency.
convDep :: PN -> Dependency -> Dep PN
convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, Goal (P pn') Unknown)])
convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, P pn')])
-- | Convert setup dependencies
convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN
......
......@@ -119,7 +119,6 @@ showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =
showGR :: QGoalReason -> String
showGR UserGoal = " (user goal)"
showGR Unknown = " (UNKNOWN GOAL)"
showGR (PDependency pi) = " (dependency of " ++ showPI pi ++ ")"
showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")"
showGR (SDependency qsn) = " (dependency of " ++ showQSNBool qsn True ++ ")"
......
......@@ -98,7 +98,7 @@ validate = cata go
where
go :: TreeF QGoalReason (Validate (Tree QGoalReason)) -> Validate (Tree QGoalReason)
go (PChoiceF qpn gr ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr) ts)
go (PChoiceF qpn gr ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) ts)
go (FChoiceF qfn gr b m ts) =
do
-- Flag choices may occur repeatedly (because they can introduce new constraints
......@@ -108,10 +108,10 @@ validate = cata go
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
Just t -> goF qfn gr rb t
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 gr) ts)
FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn) ts)
go (SChoiceF qsn gr b ts) =
do
-- Optional stanza choices are very similar to flag choices.
......@@ -119,10 +119,10 @@ validate = cata go
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
Just t -> goS qsn gr rb t
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 gr) ts)
SChoice qsn gr b <$> sequence (P.mapWithKey (goS qsn) ts)
-- We don't need to do anything for goal choices or failure nodes.
go (GoalChoiceF ts) = GoalChoice <$> sequence ts
......@@ -130,8 +130,8 @@ validate = cata go
go (FailF c fr ) = pure (Fail c fr)
-- What to do for package nodes ...
goP :: QPN -> QGoalReason -> POption -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
goP qpn@(Q _pp pn) gr (POption i _) r = do
goP :: QPN -> POption -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
goP qpn@(Q _pp pn) (POption i _) r = do
PA ppa pfa psa <- asks pa -- obtain current preassignment
extSupported <- asks supportedExt -- obtain the supported extensions
langSupported <- asks supportedLang -- obtain the supported languages
......@@ -145,8 +145,7 @@ validate = cata go
let qdeps = qualifyDeps qo qpn deps
-- the new active constraints are given by the instance we have chosen,
-- plus the dependency information we have for that instance
let goal = Goal (P qpn) gr
let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps)
let newactives = Dep qpn (Fixed i (P qpn)) : L.map (resetVar (P qpn)) (extractDeps pfa psa qdeps)
-- We now try to extend the partial assignment with the new active constraints.
let mnppa = extend extSupported langSupported pkgPresent (P qpn) ppa newactives
-- In case we continue, we save the scoped dependencies
......@@ -161,8 +160,8 @@ validate = cata go
local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r
-- What to do for flag nodes ...
goF :: QFN -> QGoalReason -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
goF qfn@(FN (PI qpn _i) _f) gr b r = do
goF :: QFN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
goF qfn@(FN (PI qpn _i) _f) b r = do
PA ppa pfa psa <- asks pa -- obtain current preassignment
extSupported <- asks supportedExt -- obtain the supported extensions
langSupported <- asks supportedLang -- obtain the supported languages
......@@ -179,15 +178,15 @@ validate = cata go
let npfa = M.insert qfn b pfa
-- We now try to get the new active dependencies we might learn about because
-- we have chosen a new flag.
let newactives = extractNewDeps (F qfn) gr b npfa psa qdeps
let newactives = extractNewDeps (F qfn) b npfa psa qdeps
-- As in the package case, we try to extend the partial assignment.
case extend extSupported langSupported pkgPresent (F qfn) ppa newactives of
Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found
Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r
-- What to do for stanza nodes (similar to flag nodes) ...
goS :: QSN -> QGoalReason -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
goS qsn@(SN (PI qpn _i) _f) gr b r = do
goS :: QSN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
goS qsn@(SN (PI qpn _i) _f) b r = do
PA ppa pfa psa <- asks pa -- obtain current preassignment
extSupported <- asks supportedExt -- obtain the supported extensions
langSupported <- asks supportedLang -- obtain the supported languages
......@@ -204,7 +203,7 @@ validate = cata go
let npsa = M.insert qsn b psa
-- We now try to get the new active dependencies we might learn about because
-- we have chosen a new flag.
let newactives = extractNewDeps (S qsn) gr b pfa npsa qdeps
let newactives = extractNewDeps (S qsn) b pfa npsa qdeps
-- As in the package case, we try to extend the partial assignment.
case extend extSupported langSupported pkgPresent (S qsn) ppa newactives of
Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found
......@@ -230,8 +229,8 @@ extractDeps fa sa deps = do
-- | We try to find new dependencies that become available due to the given
-- flag or stanza choice. We therefore look for the choice in question, and then call
-- 'extractDeps' for everything underneath.
extractNewDeps :: Var QPN -> QGoalReason -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]
extractNewDeps v gr b fa sa = go
extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]
extractNewDeps v b fa sa = go
where
go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion)
go deps = do
......@@ -239,14 +238,14 @@ extractNewDeps v gr b fa sa = go
case d of
Simple _ _ -> mzero
Flagged qfn' _ td fd
| v == F qfn' -> L.map (resetGoal (Goal v gr)) $
| v == F qfn' -> L.map (resetVar v) $
if b then extractDeps fa sa td else extractDeps fa sa fd
| otherwise -> case M.lookup qfn' fa of
Nothing -> mzero
Just True -> go td
Just False -> go fd
Stanza qsn' td
| v == S qsn' -> L.map (resetGoal (Goal v gr)) $
| v == S qsn' -> L.map (resetVar v) $
if b then extractDeps fa sa td else []
| otherwise -> case M.lookup qsn' sa of
Nothing -> mzero
......
Supports Markdown
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