Skip to content

Refactor solver goal types and remove a use of PSQ. #4430

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 2 commits into from
Apr 7, 2017
Merged

Refactor solver goal types and remove a use of PSQ. #4430

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
2245c9d
Refactor solver goal types.
grayjay Apr 1, 2017
bf551a7
Replace a use of PSQ with [].
grayjay Apr 1, 2017
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
116 changes: 71 additions & 45 deletions cabal-install/Distribution/Solver/Modular/Builder.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,8 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Solver.Modular.Builder (buildTree) where
module Distribution.Solver.Modular.Builder (
buildTree
, splits -- for testing
) where

-- Building the search tree.
--
Expand All @@ -24,12 +27,10 @@ import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Index
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.PSQ (PSQ)
import qualified Distribution.Solver.Modular.PSQ as P
import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.WeightedPSQ as W

import Distribution.Solver.Types.ComponentDeps (Component)
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Settings

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

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

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

cons' = P.cons . forgetCompOpenGoal

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

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

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

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

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

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

addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN (PI qpn _) _) t gr) }) =
SChoiceF qsn rdm gr trivial (W.fromList
[([0], False, bs { next = Goals }),
([1], True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
[([0], False, bs { next = Goals }),
([1], True, (extendOpen qpn (L.map (flip PotentialGoal (SDependency qsn)) t) bs) { next = Goals })])
where
trivial = WeakOrTrivial (L.null t)

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

qpns | ind = makeIndependent igs
| otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs

{-------------------------------------------------------------------------------
Goals
-------------------------------------------------------------------------------}

-- | Information needed about a dependency before it is converted into a Goal.
-- Not all PotentialGoals correspond to Goals. For example, PotentialGoals can
-- represent pkg-config or language extension dependencies.
data PotentialGoal = PotentialGoal (FlaggedDep QPN) QGoalReason

-- | Like a PotentialGoal, except that it always introduces a new Goal.
data OpenGoal =
FlagGoal (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason
| StanzaGoal (SN QPN) (FlaggedDeps QPN) QGoalReason
| PkgGoal QPN QGoalReason

-- | Closes a goal, i.e., removes all the extraneous information that we
-- need only during the build phase.
close :: OpenGoal -> Goal QPN
close (FlagGoal qfn _ _ _ gr) = Goal (F qfn) gr
close (StanzaGoal qsn _ gr) = Goal (S qsn) gr
close (PkgGoal qpn gr) = Goal (P qpn) gr

{-------------------------------------------------------------------------------
Auxiliary
-------------------------------------------------------------------------------}

-- | Pairs each element of a list with the list resulting from removal of that
-- element from the original list.
splits :: [a] -> [(a, [a])]
splits = go id
where
go :: ([a] -> [a]) -> [a] -> [(a, [a])]
go _ [] = []
go f (x : xs) = (x, f xs) : go (f . (x :)) xs
Loading