    {-# 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