Skip to content

Add a new field to solver Done nodes, and simplify Explore.exploreLog. #3820

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 3 commits into from
Sep 19, 2016
Merged

Add a new field to solver Done nodes, and simplify Explore.exploreLog. #3820

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
01c28ea
Remove Functor instance for solver search tree.
grayjay Sep 16, 2016
8c8fcc5
Add a new field to solver Done nodes.
grayjay Sep 10, 2016
6b7c536
Solver: Simplify Explore.exploreLog by splitting it into two traversals.
grayjay Sep 10, 2016
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
8 changes: 4 additions & 4 deletions cabal-install/Distribution/Solver/Modular/Builder.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
8 changes: 4 additions & 4 deletions cabal-install/Distribution/Solver/Modular/Cycles.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
68 changes: 37 additions & 31 deletions cabal-install/Distribution/Solver/Modular/Explore.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -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 ())
18 changes: 9 additions & 9 deletions cabal-install/Distribution/Solver/Modular/Linking.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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

Expand Down Expand Up @@ -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)
Expand All @@ -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
Expand All @@ -165,15 +165,15 @@ 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
Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
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
Expand Down
Loading