Commit 26252b42 authored by Edsko de Vries's avatar Edsko de Vries
Browse files

Replace toConflictSet by goalVar/varToConflictSet

parent fc2739e5
......@@ -64,22 +64,22 @@ data PreAssignment = PA PPreAssignment FAssignment SAssignment
extend :: (Extension -> Bool) -- ^ is a given extension supported
-> (Language -> Bool) -- ^ is a given language supported
-> (PN -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable
-> Goal QPN
-> Var QPN
-> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
extend extSupported langSupported pkgPresent goal@(Goal var _) = foldM extendSingle
extend extSupported langSupported pkgPresent var = foldM extendSingle
where
extendSingle :: PPreAssignment -> Dep QPN
-> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
extendSingle a (Ext ext ) =
if extSupported ext then Right a
else Left (toConflictSet goal, [Ext ext])
else Left (varToConflictSet var, [Ext ext])
extendSingle a (Lang lang) =
if langSupported lang then Right a
else Left (toConflictSet goal, [Lang lang])
else Left (varToConflictSet var, [Lang lang])
extendSingle a (Pkg pn vr) =
if pkgPresent pn vr then Right a
else Left (toConflictSet goal, [Pkg pn vr])
else Left (varToConflictSet var, [Pkg pn vr])
extendSingle a (Dep qpn ci) =
let ci' = M.findWithDefault (Constrained []) qpn a
in case (\ x -> M.insert qpn x a) <$> merge ci' ci of
......
......@@ -4,13 +4,9 @@ module Distribution.Client.Dependency.Modular.Cycles (
) where
import Prelude hiding (cycle)
import Control.Monad
import Control.Monad.Reader
import Data.Graph (SCC)
import Data.Map (Map)
import qualified Data.Graph as Gr
import qualified Data.Map as Map
import qualified Data.Traversable as T
import qualified Data.Graph as Gr
import qualified Data.Map as Map
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
......@@ -21,25 +17,22 @@ import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Tree
import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS
type DetectCycles = Reader (Map QPN QGoalReason)
-- | Find and reject any solutions that are cyclic
detectCyclesPhase :: Tree QGoalReason -> Tree QGoalReason
detectCyclesPhase = (`runReader` Map.empty) . cata go
detectCyclesPhase = cata go
where
-- Most cases are simple; we just need to remember which choices we made
go :: TreeF QGoalReason (DetectCycles (Tree QGoalReason)) -> DetectCycles (Tree QGoalReason)
go (PChoiceF qpn gr cs) = PChoice qpn gr <$> local (Map.insert qpn gr) (T.sequence cs)
go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m <$> T.sequence cs
go (SChoiceF qsn gr w cs) = SChoice qsn gr w <$> T.sequence cs
go (GoalChoiceF cs) = GoalChoice <$> T.sequence cs
go (FailF cs reason) = return $ Fail cs reason
-- The only node of interest is DoneF
go :: TreeF QGoalReason (Tree QGoalReason) -> Tree QGoalReason
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
go (GoalChoiceF cs) = GoalChoice cs
go (FailF cs reason) = Fail cs reason
-- 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
fullSet <- ask
return $ case findCycles fullSet revDeps of
case findCycles revDeps of
Nothing -> Done revDeps
Just relSet -> Fail relSet CyclicDependencies
......@@ -47,16 +40,17 @@ detectCyclesPhase = (`runReader` Map.empty) . cata go
-- as the full conflict set containing all decisions that led to that 'Done'
-- node, check if the solution is cyclic. If it is, return the conflict set
-- containing all decisions that could potentially break the cycle.
findCycles :: Map QPN QGoalReason -> RevDepMap -> Maybe (ConflictSet QPN)
findCycles grs revDeps = do
guard $ not (null cycles)
return $ CS.unions $ map (\(qpn, gr) -> toConflictSet $ Goal (P qpn) gr) $ head cycles
findCycles :: RevDepMap -> Maybe (ConflictSet QPN)
findCycles revDeps =
case cycles of
[] -> Nothing
c:_ -> Just $ CS.unions $ map (varToConflictSet . P) c
where
cycles :: [[(QPN, QGoalReason)]]
cycles :: [[QPN]]
cycles = [vs | Gr.CyclicSCC vs <- scc]
scc :: [SCC (QPN, QGoalReason)]
scc :: [SCC QPN]
scc = Gr.stronglyConnComp . map aux . Map.toList $ revDeps
aux :: (QPN, [(comp, QPN)]) -> ((QPN, QGoalReason), QPN, [QPN])
aux (fr, to) = ((fr, grs Map.! fr), fr, map snd to)
aux :: (QPN, [(comp, QPN)]) -> (QPN, QPN, [QPN])
aux (fr, to) = (fr, fr, map snd to)
......@@ -30,8 +30,8 @@ module Distribution.Client.Dependency.Modular.Dependency (
, GoalReason(..)
, QGoalReason
, ResetGoal(..)
, toConflictSet
, extendConflictSet
, goalVarToConflictSet
, varToConflictSet
, goalReasonToVars
-- * Open goals
, OpenGoal(..)
......@@ -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 (toConflictSet g1) (toConflictSet g2), (c, d))
| otherwise = Left (CS.union (goalVarToConflictSet g1) (goalVarToConflictSet 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 (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))
| otherwise = Left (CS.union (goalVarToConflictSet g1) (goalVarToConflictSet g2), (c, Constrained [d]))
merge c@(Constrained _) d@(Fixed _ _) = merge d c
merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss))
......@@ -337,12 +337,15 @@ instance ResetGoal Goal where
-- | Compute a singleton conflict set from a goal, containing just
-- the goal variable.
toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn
toConflictSet (Goal g _gr) = CS.singleton (simplifyVar g)
-- | Add another variable into a conflict set
extendConflictSet :: Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn
extendConflictSet = CS.insert . simplifyVar
--
-- NOTE: This is just a call to 'varToConflictSet' under the hood;
-- the 'GoalReason' is ignored.
goalVarToConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn
goalVarToConflictSet (Goal g _gr) = varToConflictSet g
-- | Compute a singleton conflict set from a 'Var'
varToConflictSet :: Var qpn -> ConflictSet qpn
varToConflictSet = CS.singleton . simplifyVar
goalReasonToVars :: Ord qpn => GoalReason qpn -> ConflictSet qpn
goalReasonToVars UserGoal = CS.empty
......
......@@ -194,19 +194,19 @@ enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]
enforcePackageConstraints pcs = trav go
where
go (PChoiceF qpn@(Q pp pn) gr ts) =
let c = toConflictSet (Goal (P qpn) gr)
let c = varToConflictSet (P qpn)
-- 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)
go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) =
let c = toConflictSet (Goal (F qfn) gr)
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)
go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) =
let c = toConflictSet (Goal (S qsn) gr)
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)
......@@ -222,7 +222,7 @@ enforceManualFlags :: Tree QGoalReason -> Tree QGoalReason
enforceManualFlags = trav go
where
go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $
let c = toConflictSet (Goal (F qfn) gr)
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)
_ -> ts -- something has been manually selected, leave things alone
......@@ -240,7 +240,7 @@ requireInstalled p = trav go
| otherwise = PChoiceF v gr cs
where
installed (POption (I _ (Inst _)) _) x = x
installed _ _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall
installed _ _ = Fail (varToConflictSet (P v)) CannotInstall
go x = x
-- | Avoid reinstalls.
......@@ -268,7 +268,7 @@ avoidReinstalls p = trav go
in P.mapWithKey (notReinstall installed) cs
notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =
Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall
Fail (varToConflictSet (P qpn)) CannotReinstall
notReinstall _ _ x =
x
go x = x
......@@ -361,7 +361,7 @@ preferReallyEasyGoalChoices = trav go
--
-- For each package instance we record the goal for which we picked a concrete
-- instance. The SIR means that for any package instance there can only be one.
type EnforceSIR = Reader (Map (PI PN) (Goal QPN))
type EnforceSIR = Reader (Map (PI PN) QPN)
-- | Enforce ghc's single instance restriction
--
......@@ -376,15 +376,14 @@ enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
-- We just verify package choices.
go (PChoiceF qpn gr cs) =
PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr) cs)
PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) cs)
go _otherwise =
innM _otherwise
-- The check proper
goP :: QPN -> QGoalReason -> POption -> EnforceSIR (Tree QGoalReason) -> EnforceSIR (Tree QGoalReason)
goP qpn@(Q _ pn) gr (POption i linkedTo) r = do
goP :: QPN -> POption -> EnforceSIR (Tree QGoalReason) -> EnforceSIR (Tree QGoalReason)
goP qpn@(Q _ pn) (POption i linkedTo) r = do
let inst = PI pn i
goal = Goal (P qpn) gr
env <- ask
case (linkedTo, M.lookup inst env) of
(Just _, _) ->
......@@ -392,7 +391,7 @@ enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
r
(Nothing, Nothing) ->
-- Not linked, not already used
local (M.insert inst goal) r
(Nothing, Just goal') -> do
local (M.insert inst qpn) r
(Nothing, Just qpn') -> do
-- Not linked, already used. This is an error
return $ Fail (CS.union (toConflictSet goal) (toConflictSet goal')) MultipleInstances
return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances
......@@ -109,7 +109,7 @@ validate = cata go
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
Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn)
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)
go (SChoiceF qsn gr b ts) =
......@@ -120,7 +120,7 @@ validate = cata go
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
Nothing -> return $ Fail (toConflictSet (Goal (S qsn) gr)) (MalformedStanzaChoice qsn)
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)
......@@ -148,12 +148,12 @@ validate = cata go
let goal = Goal (P qpn) gr
let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps)
-- We now try to extend the partial assignment with the new active constraints.
let mnppa = extend extSupported langSupported pkgPresent goal ppa newactives
let mnppa = extend extSupported langSupported pkgPresent (P qpn) ppa newactives
-- In case we continue, we save the scoped dependencies
let nsvd = M.insert qpn qdeps svd
case mfr of
Just fr -> -- The index marks this as an invalid choice. We can stop.
return (Fail (toConflictSet goal) fr)
return (Fail (varToConflictSet (P qpn)) fr)
_ -> case mnppa of
Left (c, d) -> -- We have an inconsistency. We can stop.
return (Fail c (Conflicting d))
......@@ -181,7 +181,7 @@ validate = cata go
-- we have chosen a new flag.
let newactives = extractNewDeps (F qfn) gr b npfa psa qdeps
-- As in the package case, we try to extend the partial assignment.
case extend extSupported langSupported pkgPresent (Goal (F qfn) gr) ppa newactives of
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
......@@ -206,7 +206,7 @@ validate = cata go
-- we have chosen a new flag.
let newactives = extractNewDeps (S qsn) gr b pfa npsa qdeps
-- As in the package case, we try to extend the partial assignment.
case extend extSupported langSupported pkgPresent (Goal (S qsn) gr) ppa newactives of
case extend extSupported langSupported pkgPresent (S qsn) ppa newactives of
Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found
Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r
......
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