{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Solver.Modular.Builder (
    buildTree
  , splits -- for testing
  ) where

-- Building the search tree.
--
-- In this phase, we build a search tree that is too large, i.e, it contains
-- invalid solutions. We keep track of the open goals at each point. We
-- nondeterministically pick an open goal (via a goal choice node), create
-- subtrees according to the index and the available solutions, and extend the
-- set of open goals by superficially looking at the dependencies recorded in
-- the index.
--
-- For each goal, we keep track of all the *reasons* why it is being
-- introduced. These are for debugging and error messages, mainly. A little bit
-- of care has to be taken due to the way we treat flags. If a package has
-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we
-- store the entire dependency.

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import Prelude

import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Index
import Distribution.Solver.Modular.Package
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
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Settings

-- | All state needed to build and link the search tree. It has a type variable
-- because the linking phase doesn't need to know about the state used to build
-- the tree.
data Linker a = Linker {
  forall a. Linker a -> a
buildState   :: a,
  forall a. Linker a -> LinkingState
linkingState :: LinkingState
}

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

-- | Map of available linking targets.
type LinkingState = M.Map (PN, I) [PackagePath]

-- | Extend the set of open goals with the new goals listed.
--
-- We also adjust the map of overall goals, and keep track of the
-- reverse dependencies of each of the goals.
extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState
extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState
extendOpen QPN
qpn' [FlaggedDep QPN]
gs s :: BuildState
s@(BS { rdeps :: BuildState -> RevDepMap
rdeps = RevDepMap
gs', open :: BuildState -> [OpenGoal]
open = [OpenGoal]
o' }) = RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
go RevDepMap
gs' [OpenGoal]
o' [FlaggedDep QPN]
gs
  where
    go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
    go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
go RevDepMap
g [OpenGoal]
o []                                             = BuildState
s { rdeps = g, open = o }
    go RevDepMap
g [OpenGoal]
o ((Flagged fn :: FN QPN
fn@(FN QPN
qpn Flag
_) FInfo
fInfo [FlaggedDep QPN]
t [FlaggedDep QPN]
f)  : [FlaggedDep QPN]
ngs) =
        RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
go RevDepMap
g (FN QPN
-> FInfo
-> [FlaggedDep QPN]
-> [FlaggedDep QPN]
-> QGoalReason
-> OpenGoal
FlagGoal FN QPN
fn FInfo
fInfo [FlaggedDep QPN]
t [FlaggedDep QPN]
f (QPN -> QGoalReason
forall qpn. qpn -> GoalReason qpn
flagGR QPN
qpn) OpenGoal -> [OpenGoal] -> [OpenGoal]
forall a. a -> [a] -> [a]
: [OpenGoal]
o) [FlaggedDep QPN]
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 RevDepMap
g [OpenGoal]
o ((Stanza sn :: SN QPN
sn@(SN QPN
qpn Stanza
_) [FlaggedDep QPN]
t)           : [FlaggedDep QPN]
ngs) =
        RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
go RevDepMap
g (SN QPN -> [FlaggedDep QPN] -> QGoalReason -> OpenGoal
StanzaGoal SN QPN
sn [FlaggedDep QPN]
t (QPN -> QGoalReason
forall qpn. qpn -> GoalReason qpn
flagGR QPN
qpn) OpenGoal -> [OpenGoal] -> [OpenGoal]
forall a. a -> [a] -> [a]
: [OpenGoal]
o) [FlaggedDep QPN]
ngs
    go RevDepMap
g [OpenGoal]
o ((Simple (LDep DependencyReason QPN
dr (Dep (PkgComponent QPN
qpn ExposedComponent
_) CI
_)) Component
c) : [FlaggedDep QPN]
ngs)
      | QPN
qpn QPN -> QPN -> Bool
forall a. Eq a => a -> a -> Bool
== QPN
qpn'       =
            -- We currently only add a self-dependency to the graph if it is
            -- between a package and its setup script. The edge creates a cycle
            -- and causes the solver to backtrack and choose a different
            -- instance for the setup script. We may need to track other
            -- self-dependencies once we implement component-based solving.
          case Component
c of
            Component
ComponentSetup -> RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
go (([(Component, QPN)] -> [(Component, QPN)])
-> QPN -> RevDepMap -> RevDepMap
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust ((Component, QPN) -> [(Component, QPN)] -> [(Component, QPN)]
forall a. Eq a => a -> [a] -> [a]
addIfAbsent (Component
ComponentSetup, QPN
qpn')) QPN
qpn RevDepMap
g) [OpenGoal]
o [FlaggedDep QPN]
ngs
            Component
_              -> RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
go                                                    RevDepMap
g  [OpenGoal]
o [FlaggedDep QPN]
ngs
      | QPN
qpn QPN -> RevDepMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` RevDepMap
g  = RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
go (([(Component, QPN)] -> [(Component, QPN)])
-> QPN -> RevDepMap -> RevDepMap
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust ((Component, QPN) -> [(Component, QPN)] -> [(Component, QPN)]
forall a. Eq a => a -> [a] -> [a]
addIfAbsent (Component
c, QPN
qpn')) QPN
qpn RevDepMap
g)   [OpenGoal]
o  [FlaggedDep QPN]
ngs
      | Bool
otherwise         = RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
go (QPN -> [(Component, QPN)] -> RevDepMap -> RevDepMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QPN
qpn [(Component
c, QPN
qpn')]  RevDepMap
g) (QPN -> QGoalReason -> OpenGoal
PkgGoal QPN
qpn (DependencyReason QPN -> QGoalReason
forall qpn. DependencyReason qpn -> GoalReason qpn
DependencyGoal DependencyReason QPN
dr) OpenGoal -> [OpenGoal] -> [OpenGoal]
forall a. a -> [a] -> [a]
: [OpenGoal]
o) [FlaggedDep QPN]
ngs
          -- code above is correct; insert/adjust have different arg order
    go RevDepMap
g [OpenGoal]
o ((Simple (LDep DependencyReason QPN
_dr (Ext Extension
_ext )) Component
_)  : [FlaggedDep QPN]
ngs) = RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
go RevDepMap
g [OpenGoal]
o [FlaggedDep QPN]
ngs
    go RevDepMap
g [OpenGoal]
o ((Simple (LDep DependencyReason QPN
_dr (Lang Language
_lang))Component
_)  : [FlaggedDep QPN]
ngs) = RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
go RevDepMap
g [OpenGoal]
o [FlaggedDep QPN]
ngs
    go RevDepMap
g [OpenGoal]
o ((Simple (LDep DependencyReason QPN
_dr (Pkg PkgconfigName
_pn PkgconfigVersionRange
_vr))Component
_) : [FlaggedDep QPN]
ngs) = RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState
go RevDepMap
g [OpenGoal]
o [FlaggedDep QPN]
ngs

    addIfAbsent :: Eq a => a -> [a] -> [a]
    addIfAbsent :: forall a. Eq a => a -> [a] -> [a]
addIfAbsent a
x [a]
xs = if a
x a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
xs then [a]
xs else a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs

    -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by
    -- its containing package.
    flagGR :: qpn -> GoalReason qpn
    flagGR :: forall qpn. qpn -> GoalReason qpn
flagGR qpn
qpn = DependencyReason qpn -> GoalReason qpn
forall qpn. DependencyReason qpn -> GoalReason qpn
DependencyGoal (qpn -> Map Flag FlagValue -> Set Stanza -> DependencyReason qpn
forall qpn.
qpn -> Map Flag FlagValue -> Set Stanza -> DependencyReason qpn
DependencyReason qpn
qpn Map Flag FlagValue
forall k a. Map k a
M.empty Set Stanza
forall a. Set a
S.empty)

-- | 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 -> FlaggedDeps PN -> FlagInfo ->
                    BuildState -> BuildState
scopedExtendOpen :: QPN
-> FlaggedDeps PackageName -> FlagInfo -> BuildState -> BuildState
scopedExtendOpen QPN
qpn FlaggedDeps PackageName
fdeps FlagInfo
fdefs BuildState
s = QPN -> [FlaggedDep QPN] -> BuildState -> BuildState
extendOpen QPN
qpn [FlaggedDep QPN]
gs BuildState
s
  where
    -- Qualify all package names
    qfdeps :: [FlaggedDep QPN]
qfdeps = QualifyOptions
-> QPN -> FlaggedDeps PackageName -> [FlaggedDep QPN]
qualifyDeps (BuildState -> QualifyOptions
qualifyOptions BuildState
s) QPN
qpn FlaggedDeps PackageName
fdeps
    -- Introduce all package flags
    qfdefs :: [FlaggedDep QPN]
qfdefs = ((Flag, FInfo) -> FlaggedDep QPN)
-> [(Flag, FInfo)] -> [FlaggedDep QPN]
forall a b. (a -> b) -> [a] -> [b]
L.map (\ (Flag
fn, FInfo
b) -> FN QPN
-> FInfo -> [FlaggedDep QPN] -> [FlaggedDep QPN] -> FlaggedDep QPN
forall qpn.
FN qpn
-> FInfo
-> TrueFlaggedDeps qpn
-> TrueFlaggedDeps qpn
-> FlaggedDep qpn
Flagged (QPN -> Flag -> FN QPN
forall qpn. qpn -> Flag -> FN qpn
FN QPN
qpn Flag
fn) FInfo
b [] []) ([(Flag, FInfo)] -> [FlaggedDep QPN])
-> [(Flag, FInfo)] -> [FlaggedDep QPN]
forall a b. (a -> b) -> a -> b
$ FlagInfo -> [(Flag, FInfo)]
forall k a. Map k a -> [(k, a)]
M.toList FlagInfo
fdefs
    -- Combine new package and flag goals
    gs :: [FlaggedDep QPN]
gs     = [FlaggedDep QPN]
qfdefs [FlaggedDep QPN] -> [FlaggedDep QPN] -> [FlaggedDep QPN]
forall a. [a] -> [a] -> [a]
++ [FlaggedDep QPN]
qfdeps
    -- NOTE:
    --
    -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially
    -- multiple times, both via the flag declaration and via dependencies.

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

build :: Linker BuildState -> Tree () QGoalReason
build :: Linker BuildState -> Tree () QGoalReason
build = (Linker BuildState -> TreeF () QGoalReason (Linker BuildState))
-> Linker BuildState -> Tree () QGoalReason
forall a d c. (a -> TreeF d c a) -> a -> Tree d c
ana Linker BuildState -> TreeF () QGoalReason (Linker BuildState)
go
  where
    go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState)
    go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState)
go Linker BuildState
s = LinkingState
-> TreeF () QGoalReason BuildState
-> TreeF () QGoalReason (Linker BuildState)
forall c a. LinkingState -> TreeF () c a -> TreeF () c (Linker a)
addLinking (Linker BuildState -> LinkingState
forall a. Linker a -> LinkingState
linkingState Linker BuildState
s) (TreeF () QGoalReason BuildState
 -> TreeF () QGoalReason (Linker BuildState))
-> TreeF () QGoalReason BuildState
-> TreeF () QGoalReason (Linker BuildState)
forall a b. (a -> b) -> a -> b
$ BuildState -> TreeF () QGoalReason BuildState
addChildren (Linker BuildState -> BuildState
forall a. Linker a -> a
buildState Linker BuildState
s)

addChildren :: 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.
addChildren :: BuildState -> TreeF () QGoalReason BuildState
addChildren bs :: BuildState
bs@(BS { rdeps :: BuildState -> RevDepMap
rdeps = RevDepMap
rdm, open :: BuildState -> [OpenGoal]
open = [OpenGoal]
gs, next :: BuildState -> BuildType
next = BuildType
Goals })
  | [OpenGoal] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [OpenGoal]
gs = RevDepMap -> () -> TreeF () QGoalReason BuildState
forall d c a. RevDepMap -> d -> TreeF d c a
DoneF RevDepMap
rdm ()
  | Bool
otherwise = RevDepMap
-> PSQ (Goal QPN) BuildState -> TreeF () QGoalReason BuildState
forall d c a. RevDepMap -> PSQ (Goal QPN) a -> TreeF d c a
GoalChoiceF RevDepMap
rdm (PSQ (Goal QPN) BuildState -> TreeF () QGoalReason BuildState)
-> PSQ (Goal QPN) BuildState -> TreeF () QGoalReason BuildState
forall a b. (a -> b) -> a -> b
$ [(Goal QPN, BuildState)] -> PSQ (Goal QPN) BuildState
forall k a. [(k, a)] -> PSQ k a
P.fromList
                                ([(Goal QPN, BuildState)] -> PSQ (Goal QPN) BuildState)
-> [(Goal QPN, BuildState)] -> PSQ (Goal QPN) BuildState
forall a b. (a -> b) -> a -> b
$ ((OpenGoal, [OpenGoal]) -> (Goal QPN, BuildState))
-> [(OpenGoal, [OpenGoal])] -> [(Goal QPN, BuildState)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\ (OpenGoal
g, [OpenGoal]
gs') -> (OpenGoal -> Goal QPN
close OpenGoal
g, BuildState
bs { next = OneGoal g, open = gs' }))
                                ([(OpenGoal, [OpenGoal])] -> [(Goal QPN, BuildState)])
-> [(OpenGoal, [OpenGoal])] -> [(Goal QPN, BuildState)]
forall a b. (a -> b) -> a -> b
$ [OpenGoal] -> [(OpenGoal, [OpenGoal])]
forall a. [a] -> [(a, [a])]
splits [OpenGoal]
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 :: BuildState
bs@(BS { rdeps :: BuildState -> RevDepMap
rdeps = RevDepMap
rdm, index :: BuildState -> Index
index = Index
idx, next :: BuildState -> BuildType
next = OneGoal (PkgGoal qpn :: QPN
qpn@(Q PackagePath
_ PackageName
pn) QGoalReason
gr) }) =
  case PackageName -> Index -> Maybe (Map I PInfo)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
pn Index
idx of
    Maybe (Map I PInfo)
Nothing  -> ConflictSet -> FailReason -> TreeF () QGoalReason BuildState
forall d c a. ConflictSet -> FailReason -> TreeF d c a
FailF
                (Var QPN -> ConflictSet
varToConflictSet (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn) ConflictSet -> ConflictSet -> ConflictSet
`CS.union` QPN -> QGoalReason -> ConflictSet
goalReasonToConflictSetWithConflict QPN
qpn QGoalReason
gr)
                FailReason
UnknownPackage
    Just Map I PInfo
pis -> QPN
-> RevDepMap
-> QGoalReason
-> WeightedPSQ [Weight] POption BuildState
-> TreeF () QGoalReason BuildState
forall d c a.
QPN
-> RevDepMap -> c -> WeightedPSQ [Weight] POption a -> TreeF d c a
PChoiceF QPN
qpn RevDepMap
rdm QGoalReason
gr ([([Weight], POption, BuildState)]
-> WeightedPSQ [Weight] POption BuildState
forall w k v. Ord w => [(w, k, v)] -> WeightedPSQ w k v
W.fromList (((I, PInfo) -> ([Weight], POption, BuildState))
-> [(I, PInfo)] -> [([Weight], POption, BuildState)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\ (I
i, PInfo
info) ->
                                                       ([], I -> Maybe PackagePath -> POption
POption I
i Maybe PackagePath
forall a. Maybe a
Nothing, BuildState
bs { next = Instance qpn info }))
                                                     (Map I PInfo -> [(I, PInfo)]
forall k a. Map k a -> [(k, a)]
M.toList Map I PInfo
pis)))
      -- TODO: data structure conversion is rather ugly here

-- For a flag, we create only two subtrees, and we create them in the order
-- that is indicated by the flag default.
addChildren bs :: BuildState
bs@(BS { rdeps :: BuildState -> RevDepMap
rdeps = RevDepMap
rdm, next :: BuildState -> BuildType
next = OneGoal (FlagGoal qfn :: FN QPN
qfn@(FN QPN
qpn Flag
_) (FInfo Bool
b FlagType
m WeakOrTrivial
w) [FlaggedDep QPN]
t [FlaggedDep QPN]
f QGoalReason
gr) }) =
  FN QPN
-> RevDepMap
-> QGoalReason
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool BuildState
-> TreeF () QGoalReason BuildState
forall d c a.
FN QPN
-> RevDepMap
-> c
-> WeakOrTrivial
-> FlagType
-> Bool
-> WeightedPSQ [Weight] Bool a
-> TreeF d c a
FChoiceF FN QPN
qfn RevDepMap
rdm QGoalReason
gr WeakOrTrivial
weak FlagType
m Bool
b ([([Weight], Bool, BuildState)]
-> WeightedPSQ [Weight] Bool BuildState
forall w k v. Ord w => [(w, k, v)] -> WeightedPSQ w k v
W.fromList
    [([if Bool
b then Weight
0 else Weight
1], Bool
True,  (QPN -> [FlaggedDep QPN] -> BuildState -> BuildState
extendOpen QPN
qpn [FlaggedDep QPN]
t BuildState
bs) { next = Goals }),
     ([if Bool
b then Weight
1 else Weight
0], Bool
False, (QPN -> [FlaggedDep QPN] -> BuildState -> BuildState
extendOpen QPN
qpn [FlaggedDep QPN]
f BuildState
bs) { next = Goals })])
  where
    trivial :: Bool
trivial = [FlaggedDep QPN] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [FlaggedDep QPN]
t Bool -> Bool -> Bool
&& [FlaggedDep QPN] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [FlaggedDep QPN]
f
    weak :: WeakOrTrivial
weak = Bool -> WeakOrTrivial
WeakOrTrivial (Bool -> WeakOrTrivial) -> Bool -> WeakOrTrivial
forall a b. (a -> b) -> a -> b
$ WeakOrTrivial -> Bool
unWeakOrTrivial WeakOrTrivial
w Bool -> Bool -> Bool
|| Bool
trivial

-- For a stanza, we also create only two subtrees. The order is initially
-- False, True. This can be changed later by constraints (force enabling
-- 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 :: BuildState
bs@(BS { rdeps :: BuildState -> RevDepMap
rdeps = RevDepMap
rdm, next :: BuildState -> BuildType
next = OneGoal (StanzaGoal qsn :: SN QPN
qsn@(SN QPN
qpn Stanza
_) [FlaggedDep QPN]
t QGoalReason
gr) }) =
  SN QPN
-> RevDepMap
-> QGoalReason
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool BuildState
-> TreeF () QGoalReason BuildState
forall d c a.
SN QPN
-> RevDepMap
-> c
-> WeakOrTrivial
-> WeightedPSQ [Weight] Bool a
-> TreeF d c a
SChoiceF SN QPN
qsn RevDepMap
rdm QGoalReason
gr WeakOrTrivial
trivial ([([Weight], Bool, BuildState)]
-> WeightedPSQ [Weight] Bool BuildState
forall w k v. Ord w => [(w, k, v)] -> WeightedPSQ w k v
W.fromList
    [([Weight
0], Bool
False,                                                                  BuildState
bs  { next = Goals }),
     ([Weight
1], Bool
True,  (QPN -> [FlaggedDep QPN] -> BuildState -> BuildState
extendOpen QPN
qpn [FlaggedDep QPN]
t BuildState
bs) { next = Goals })])
  where
    trivial :: WeakOrTrivial
trivial = Bool -> WeakOrTrivial
WeakOrTrivial ([FlaggedDep QPN] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [FlaggedDep QPN]
t)

-- For a particular instance, we change the state: we update the scope,
-- and furthermore we update the set of goals.
--
-- TODO: We could inline this above.
addChildren bs :: BuildState
bs@(BS { next :: BuildState -> BuildType
next = Instance QPN
qpn (PInfo FlaggedDeps PackageName
fdeps Map ExposedComponent ComponentInfo
_ FlagInfo
fdefs Maybe FailReason
_) }) =
  BuildState -> TreeF () QGoalReason BuildState
addChildren ((QPN
-> FlaggedDeps PackageName -> FlagInfo -> BuildState -> BuildState
scopedExtendOpen QPN
qpn FlaggedDeps PackageName
fdeps FlagInfo
fdefs BuildState
bs)
         { next = Goals })

{-------------------------------------------------------------------------------
  Add linking
-------------------------------------------------------------------------------}

-- | Introduce link nodes into the tree
--
-- Linking is a phase that adapts package choice nodes and adds the option to
-- link wherever appropriate: Package goals are called "related" if they are for
-- the same instance of the same package (but have different prefixes). A link
-- option is available in a package choice node whenever we can choose an
-- instance that has already been chosen for a related goal at a higher position
-- in the tree. We only create link options for related goals that are not
-- themselves linked, because the choice to link to a linked goal is the same as
-- the choice to link to the target of that goal's linking.
--
-- The code here proceeds by maintaining a finite map recording choices that
-- have been made at higher positions in the tree. For each pair of package name
-- and instance, it stores the prefixes at which we have made a choice for this
-- 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.
--
-- A separate tree traversal would be simpler. However, 'addLinking' creates
-- linked nodes from existing unlinked nodes, which leads to sharing between the
-- nodes. If we copied the nodes when they were full trees of type
-- 'Tree () QGoalReason', then the sharing would cause a space leak during
-- exploration of the tree. Instead, we only copy the 'BuildState', which is
-- relatively small, while the tree is being constructed. See
-- https://github.com/haskell/cabal/issues/2899
addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a)
-- The only nodes of interest are package nodes
addLinking :: forall c a. LinkingState -> TreeF () c a -> TreeF () c (Linker a)
addLinking LinkingState
ls (PChoiceF qpn :: QPN
qpn@(Q PackagePath
pp PackageName
pn) RevDepMap
rdm c
gr WeightedPSQ [Weight] POption a
cs) =
  let linkedCs :: WeightedPSQ [Weight] POption (Linker a)
linkedCs = (a -> Linker a)
-> WeightedPSQ [Weight] POption a
-> WeightedPSQ [Weight] POption (Linker a)
forall a b.
(a -> b)
-> WeightedPSQ [Weight] POption a -> WeightedPSQ [Weight] POption b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
bs -> a -> LinkingState -> Linker a
forall a. a -> LinkingState -> Linker a
Linker a
bs LinkingState
ls) (WeightedPSQ [Weight] POption a
 -> WeightedPSQ [Weight] POption (Linker a))
-> WeightedPSQ [Weight] POption a
-> WeightedPSQ [Weight] POption (Linker a)
forall a b. (a -> b) -> a -> b
$
                 [([Weight], POption, a)] -> WeightedPSQ [Weight] POption a
forall w k v. Ord w => [(w, k, v)] -> WeightedPSQ w k v
W.fromList ([([Weight], POption, a)] -> WeightedPSQ [Weight] POption a)
-> [([Weight], POption, a)] -> WeightedPSQ [Weight] POption a
forall a b. (a -> b) -> a -> b
$ (([Weight], POption, a) -> [([Weight], POption, a)])
-> [([Weight], POption, a)] -> [([Weight], POption, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LinkingState
-> QPN -> ([Weight], POption, a) -> [([Weight], POption, a)]
forall a w.
LinkingState -> QPN -> (w, POption, a) -> [(w, POption, a)]
linkChoices LinkingState
ls QPN
qpn) (WeightedPSQ [Weight] POption a -> [([Weight], POption, a)]
forall w k v. WeightedPSQ w k v -> [(w, k, v)]
W.toList WeightedPSQ [Weight] POption a
cs)
      unlinkedCs :: WeightedPSQ [Weight] POption (Linker a)
unlinkedCs = (POption -> a -> Linker a)
-> WeightedPSQ [Weight] POption a
-> WeightedPSQ [Weight] POption (Linker a)
forall k v1 v2 w.
(k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2
W.mapWithKey POption -> a -> Linker a
forall a. POption -> a -> Linker a
goP WeightedPSQ [Weight] POption a
cs
      allCs :: WeightedPSQ [Weight] POption (Linker a)
allCs = WeightedPSQ [Weight] POption (Linker a)
unlinkedCs WeightedPSQ [Weight] POption (Linker a)
-> WeightedPSQ [Weight] POption (Linker a)
-> WeightedPSQ [Weight] POption (Linker a)
forall w k v.
Ord w =>
WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v
`W.union` WeightedPSQ [Weight] POption (Linker a)
linkedCs

      -- Recurse underneath package choices. Here we just need to make sure
      -- that we record the package choice so that it is available below
      goP :: POption -> a -> Linker a
      goP :: forall a. POption -> a -> Linker a
goP (POption I
i Maybe PackagePath
Nothing) a
bs = a -> LinkingState -> Linker a
forall a. a -> LinkingState -> Linker a
Linker a
bs (LinkingState -> Linker a) -> LinkingState -> Linker a
forall a b. (a -> b) -> a -> b
$ ([PackagePath] -> [PackagePath] -> [PackagePath])
-> (PackageName, I)
-> [PackagePath]
-> LinkingState
-> LinkingState
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith [PackagePath] -> [PackagePath] -> [PackagePath]
forall a. [a] -> [a] -> [a]
(++) (PackageName
pn, I
i) [PackagePath
pp] LinkingState
ls
      goP POption
_                   a
_  = Linker a
forall a. a
alreadyLinked
  in QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Linker a)
-> TreeF () c (Linker a)
forall d c a.
QPN
-> RevDepMap -> c -> WeightedPSQ [Weight] POption a -> TreeF d c a
PChoiceF QPN
qpn RevDepMap
rdm c
gr WeightedPSQ [Weight] POption (Linker a)
allCs
addLinking LinkingState
ls TreeF () c a
t = (a -> Linker a) -> TreeF () c a -> TreeF () c (Linker a)
forall a b. (a -> b) -> TreeF () c a -> TreeF () c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
bs -> a -> LinkingState -> Linker a
forall a. a -> LinkingState -> Linker a
Linker a
bs LinkingState
ls) TreeF () c a
t

linkChoices :: forall a w . LinkingState
            -> QPN
            -> (w, POption, a)
            -> [(w, POption, a)]
linkChoices :: forall a w.
LinkingState -> QPN -> (w, POption, a) -> [(w, POption, a)]
linkChoices LinkingState
related (Q PackagePath
_pp PackageName
pn) (w
weight, POption I
i Maybe PackagePath
Nothing, a
subtree) =
    (PackagePath -> (w, POption, a))
-> [PackagePath] -> [(w, POption, a)]
forall a b. (a -> b) -> [a] -> [b]
L.map PackagePath -> (w, POption, a)
aux ([PackagePath] -> (PackageName, I) -> LinkingState -> [PackagePath]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] (PackageName
pn, I
i) LinkingState
related)
  where
    aux :: PackagePath -> (w, POption, a)
    aux :: PackagePath -> (w, POption, a)
aux PackagePath
pp = (w
weight, I -> Maybe PackagePath -> POption
POption I
i (PackagePath -> Maybe PackagePath
forall a. a -> Maybe a
Just PackagePath
pp), a
subtree)
linkChoices LinkingState
_ QPN
_ (w
_, POption I
_ (Just PackagePath
_), a
_) =
    [(w, POption, a)]
forall a. a
alreadyLinked

alreadyLinked :: a
alreadyLinked :: forall a. a
alreadyLinked = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"addLinking called on tree that already contains linked nodes"

-------------------------------------------------------------------------------

-- | 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 -> [PackageName] -> Tree () QGoalReason
buildTree Index
idx (IndependentGoals Bool
ind) [PackageName]
igs =
    Linker BuildState -> Tree () QGoalReason
build Linker {
        buildState :: BuildState
buildState = BS {
            index :: Index
index = Index
idx
          , rdeps :: RevDepMap
rdeps = [(QPN, [(Component, QPN)])] -> RevDepMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((QPN -> (QPN, [(Component, QPN)]))
-> [QPN] -> [(QPN, [(Component, QPN)])]
forall a b. (a -> b) -> [a] -> [b]
L.map (\ QPN
qpn -> (QPN
qpn, []))              [QPN]
qpns)
          , open :: [OpenGoal]
open  = (QPN -> OpenGoal) -> [QPN] -> [OpenGoal]
forall a b. (a -> b) -> [a] -> [b]
L.map QPN -> OpenGoal
topLevelGoal [QPN]
qpns
          , next :: BuildType
next  = BuildType
Goals
          , qualifyOptions :: QualifyOptions
qualifyOptions = Index -> QualifyOptions
defaultQualifyOptions Index
idx
          }
      , linkingState :: LinkingState
linkingState = LinkingState
forall k a. Map k a
M.empty
      }
  where
    topLevelGoal :: QPN -> OpenGoal
topLevelGoal QPN
qpn = QPN -> QGoalReason -> OpenGoal
PkgGoal QPN
qpn QGoalReason
forall qpn. GoalReason qpn
UserGoal

    qpns :: [QPN]
qpns | Bool
ind       = (PackageName -> QPN) -> [PackageName] -> [QPN]
forall a b. (a -> b) -> [a] -> [b]
L.map PackageName -> QPN
makeIndependent [PackageName]
igs
         | Bool
otherwise = (PackageName -> QPN) -> [PackageName] -> [QPN]
forall a b. (a -> b) -> [a] -> [b]
L.map (PackagePath -> PackageName -> QPN
forall a. PackagePath -> a -> Qualified a
Q (Namespace -> Qualifier -> PackagePath
PackagePath Namespace
DefaultNamespace Qualifier
QualToplevel)) [PackageName]
igs

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

-- | Information needed about a dependency before it is converted into a 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 :: OpenGoal -> Goal QPN
close (FlagGoal   FN QPN
qfn FInfo
_ [FlaggedDep QPN]
_ [FlaggedDep QPN]
_ QGoalReason
gr) = Var QPN -> QGoalReason -> Goal QPN
forall qpn. Var qpn -> GoalReason qpn -> Goal qpn
Goal (FN QPN -> Var QPN
forall qpn. FN qpn -> Var qpn
F FN QPN
qfn) QGoalReason
gr
close (StanzaGoal SN QPN
qsn [FlaggedDep QPN]
_     QGoalReason
gr) = Var QPN -> QGoalReason -> Goal QPN
forall qpn. Var qpn -> GoalReason qpn -> Goal qpn
Goal (SN QPN -> Var QPN
forall qpn. SN qpn -> Var qpn
S SN QPN
qsn) QGoalReason
gr
close (PkgGoal    QPN
qpn       QGoalReason
gr) = Var QPN -> QGoalReason -> Goal QPN
forall qpn. Var qpn -> GoalReason qpn -> Goal qpn
Goal (QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn) QGoalReason
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 :: forall a. [a] -> [(a, [a])]
splits = ([a] -> [a]) -> [a] -> [(a, [a])]
forall a. ([a] -> [a]) -> [a] -> [(a, [a])]
go [a] -> [a]
forall a. a -> a
id
  where
    go :: ([a] -> [a]) -> [a] -> [(a, [a])]
    go :: forall a. ([a] -> [a]) -> [a] -> [(a, [a])]
go [a] -> [a]
_ [] = []
    go [a] -> [a]
f (a
x : [a]
xs) = (a
x, [a] -> [a]
f [a]
xs) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: ([a] -> [a]) -> [a] -> [(a, [a])]
forall a. ([a] -> [a]) -> [a] -> [(a, [a])]
go ([a] -> [a]
f ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) [a]
xs