Skip to content

Commit cc3be39

Browse files
grayjaygrayjay
authored
Merge pull request #4430 from grayjay/solver-refactoring
Refactor solver goal types and remove a use of PSQ.
2 parents 3b8ee83 + bf551a7 commit cc3be39

File tree

12 files changed

+154
-212
lines changed

12 files changed

+154
-212
lines changed

‎cabal-install/Distribution/Solver/Modular/Builder.hs

Lines changed: 71 additions & 45 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,8 @@
11
{-# LANGUAGE ScopedTypeVariables #-}
2-
module Distribution.Solver.Modular.Builder (buildTree) where
2+
module Distribution.Solver.Modular.Builder (
3+
buildTree
4+
, splits -- for testing
5+
) where
36

47
-- Building the search tree.
58
--
@@ -24,12 +27,10 @@ import Distribution.Solver.Modular.Dependency
2427
import Distribution.Solver.Modular.Flag
2528
import Distribution.Solver.Modular.Index
2629
import Distribution.Solver.Modular.Package
27-
import Distribution.Solver.Modular.PSQ (PSQ)
2830
import qualified Distribution.Solver.Modular.PSQ as P
2931
import Distribution.Solver.Modular.Tree
3032
import qualified Distribution.Solver.Modular.WeightedPSQ as W
3133

32-
import Distribution.Solver.Types.ComponentDeps (Component)
3334
import Distribution.Solver.Types.PackagePath
3435
import Distribution.Solver.Types.Settings
3536

@@ -43,11 +44,11 @@ data Linker a = Linker {
4344

4445
-- | The state needed to build the search tree without creating any linked nodes.
4546
data BuildState = BS {
46-
index :: Index, -- ^ information about packages and their dependencies
47-
rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies
48-
open :: PSQ (OpenGoal ()) (), -- ^ set of still open goals (flag and package goals)
49-
next :: BuildType, -- ^ kind of node to generate next
50-
qualifyOptions :: QualifyOptions -- ^ qualification options
47+
index :: Index, -- ^ information about packages and their dependencies
48+
rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies
49+
open :: [OpenGoal], -- ^ set of still open goals (flag and package goals)
50+
next :: BuildType, -- ^ kind of node to generate next
51+
qualifyOptions :: QualifyOptions -- ^ qualification options
5152
}
5253

5354
-- | Map of available linking targets.
@@ -57,34 +58,33 @@ type LinkingState = Map (PN, I) [PackagePath]
5758
--
5859
-- We also adjust the map of overall goals, and keep track of the
5960
-- reverse dependencies of each of the goals.
60-
extendOpen :: QPN -> [OpenGoal Component] -> BuildState -> BuildState
61+
extendOpen :: QPN -> [PotentialGoal] -> BuildState -> BuildState
6162
extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
6263
where
63-
go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState
64-
go g o [] = s { rdeps = g, open = o }
65-
go g o (ng@(OpenGoal (Flagged _ _ _ _) _gr) : ngs) = go g (cons' ng () o) ngs
64+
go :: RevDepMap -> [OpenGoal] -> [PotentialGoal] -> BuildState
65+
go g o [] = s { rdeps = g, open = o }
66+
go g o ((PotentialGoal (Flagged fn fInfo t f) gr) : ngs) = go g (FlagGoal fn fInfo t f gr : o) ngs
6667
-- Note: for 'Flagged' goals, we always insert, so later additions win.
6768
-- This is important, because in general, if a goal is inserted twice,
6869
-- the later addition will have better dependency information.
69-
go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons' ng () o) ngs
70-
go g o (ng@(OpenGoal (Simple (Dep _ qpn _) c) _gr) : ngs)
70+
go g o ((PotentialGoal (Stanza sn t) gr) : ngs) = go g (StanzaGoal sn t gr : o) ngs
71+
go g o ((PotentialGoal (Simple (Dep _ qpn _) c) gr) : ngs)
7172
| qpn == qpn' = go g o ngs
7273
-- we ignore self-dependencies at this point; TODO: more care may be needed
7374
| qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs
74-
| otherwise = go (M.insert qpn [(c, qpn')] g) (cons' ng () o) ngs
75+
| otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn gr : o) ngs
7576
-- code above is correct; insert/adjust have different arg order
76-
go g o ( (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs
77-
go g o ( (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs
78-
go g o ( (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs
77+
go g o ((PotentialGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs
78+
go g o ((PotentialGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs
79+
go g o ((PotentialGoal (Simple (Pkg _pn _vr)_) _gr) : ngs) = go g o ngs
7980

80-
cons' = P.cons . forgetCompOpenGoal
8181

8282
addIfAbsent :: Eq a => a -> [a] -> [a]
8383
addIfAbsent x xs = if x `elem` xs then xs else x : xs
8484

8585
-- | Given the current scope, qualify all the package names in the given set of
8686
-- dependencies and then extend the set of open goals accordingly.
87-
scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo ->
87+
scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps PN -> FlagInfo ->
8888
BuildState -> BuildState
8989
scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
9090
where
@@ -93,7 +93,7 @@ scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
9393
-- Introduce all package flags
9494
qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs
9595
-- Combine new package and flag goals
96-
gs = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps)
96+
gs = L.map (flip PotentialGoal gr) (qfdefs ++ qfdeps)
9797
-- NOTE:
9898
--
9999
-- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially
@@ -112,10 +112,9 @@ scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
112112

113113
-- | Datatype that encodes what to build next
114114
data BuildType =
115-
Goals -- ^ build a goal choice node
116-
| OneGoal (OpenGoal ()) -- ^ build a node for this goal
115+
Goals -- ^ build a goal choice node
116+
| OneGoal OpenGoal -- ^ build a node for this goal
117117
| Instance QPN I PInfo QGoalReason -- ^ build a tree for a concrete instance
118-
deriving Show
119118

120119
build :: Linker BuildState -> Tree () QGoalReason
121120
build = ana go
@@ -129,23 +128,17 @@ addChildren :: BuildState -> TreeF () QGoalReason BuildState
129128
-- the tree. We select each open goal in turn, and before we descend, remove
130129
-- it from the queue of open goals.
131130
addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals })
132-
| P.null gs = DoneF rdm ()
133-
| otherwise = GoalChoiceF rdm $ P.mapKeys close
134-
$ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })
135-
$ P.splits gs
131+
| L.null gs = DoneF rdm ()
132+
| otherwise = GoalChoiceF rdm $ P.fromList
133+
$ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' }))
134+
$ splits gs
136135

137136
-- If we have already picked a goal, then the choice depends on the kind
138137
-- of goal.
139138
--
140139
-- For a package, we look up the instances available in the global info,
141140
-- and then handle each instance in turn.
142-
addChildren (BS { index = _ , next = OneGoal (OpenGoal (Simple (Ext _ ) _) _ ) }) =
143-
error "Distribution.Solver.Modular.Builder: addChildren called with Ext goal"
144-
addChildren (BS { index = _ , next = OneGoal (OpenGoal (Simple (Lang _ ) _) _ ) }) =
145-
error "Distribution.Solver.Modular.Builder: addChildren called with Lang goal"
146-
addChildren (BS { index = _ , next = OneGoal (OpenGoal (Simple (Pkg _ _ ) _) _ ) }) =
147-
error "Distribution.Solver.Modular.Builder: addChildren called with Pkg goal"
148-
addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) =
141+
addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) =
149142
-- If the package does not exist in the index, we construct an emty PChoiceF node for it
150143
-- After all, we have no choices here. Alternatively, we could immediately construct
151144
-- a Fail node here, but that would complicate the construction of conflict sets.
@@ -160,10 +153,10 @@ addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (OpenGoal (Simple
160153

161154
-- For a flag, we create only two subtrees, and we create them in the order
162155
-- that is indicated by the flag default.
163-
addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
156+
addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN (PI qpn _) _) (FInfo b m w) t f gr) }) =
164157
FChoiceF qfn rdm gr weak m b (W.fromList
165-
[([if b then 0 else 1], True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),
166-
([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })])
158+
[([if b then 0 else 1], True, (extendOpen qpn (L.map (flip PotentialGoal (FDependency qfn True )) t) bs) { next = Goals }),
159+
([if b then 1 else 0], False, (extendOpen qpn (L.map (flip PotentialGoal (FDependency qfn False)) f) bs) { next = Goals })])
167160
where
168161
trivial = L.null t && L.null f
169162
weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
@@ -173,10 +166,10 @@ addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI
173166
-- the stanza by replacing the False branch with failure) or preferences
174167
-- (try enabling the stanza if possible by moving the True branch first).
175168

176-
addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
169+
addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN (PI qpn _) _) t gr) }) =
177170
SChoiceF qsn rdm gr trivial (W.fromList
178-
[([0], False, bs { next = Goals }),
179-
([1], True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
171+
[([0], False, bs { next = Goals }),
172+
([1], True, (extendOpen qpn (L.map (flip PotentialGoal (SDependency qsn)) t) bs) { next = Goals })])
180173
where
181174
trivial = WeakOrTrivial (L.null t)
182175

@@ -258,16 +251,49 @@ buildTree idx (IndependentGoals ind) igs =
258251
buildState = BS {
259252
index = idx
260253
, rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns)
261-
, open = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns)
254+
, open = L.map topLevelGoal qpns
262255
, next = Goals
263256
, qualifyOptions = defaultQualifyOptions idx
264257
}
265258
, linkingState = M.empty
266259
}
267260
where
268-
-- Should a top-level goal allowed to be an executable style
269-
-- dependency? Well, I don't think it would make much difference
270-
topLevelGoal qpn = OpenGoal (Simple (Dep False {- not exe -} qpn (Constrained [])) ()) UserGoal
261+
topLevelGoal qpn = PkgGoal qpn UserGoal
271262

272263
qpns | ind = makeIndependent igs
273264
| otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs
265+
266+
{-------------------------------------------------------------------------------
267+
Goals
268+
-------------------------------------------------------------------------------}
269+
270+
-- | Information needed about a dependency before it is converted into a Goal.
271+
-- Not all PotentialGoals correspond to Goals. For example, PotentialGoals can
272+
-- represent pkg-config or language extension dependencies.
273+
data PotentialGoal = PotentialGoal (FlaggedDep QPN) QGoalReason
274+
275+
-- | Like a PotentialGoal, except that it always introduces a new Goal.
276+
data OpenGoal =
277+
FlagGoal (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason
278+
| StanzaGoal (SN QPN) (FlaggedDeps QPN) QGoalReason
279+
| PkgGoal QPN QGoalReason
280+
281+
-- | Closes a goal, i.e., removes all the extraneous information that we
282+
-- need only during the build phase.
283+
close :: OpenGoal -> Goal QPN
284+
close (FlagGoal qfn _ _ _ gr) = Goal (F qfn) gr
285+
close (StanzaGoal qsn _ gr) = Goal (S qsn) gr
286+
close (PkgGoal qpn gr) = Goal (P qpn) gr
287+
288+
{-------------------------------------------------------------------------------
289+
Auxiliary
290+
-------------------------------------------------------------------------------}
291+
292+
-- | Pairs each element of a list with the list resulting from removal of that
293+
-- element from the original list.
294+
splits :: [a] -> [(a, [a])]
295+
splits = go id
296+
where
297+
go :: ([a] -> [a]) -> [a] -> [(a, [a])]
298+
go _ [] = []
299+
go f (x : xs) = (x, f xs) : go (f . (x :)) xs

0 commit comments

Comments
 (0)