    {-# LANGUAGE TypeFamilies #-}
    module Distribution.Solver.Modular.Cycles (
        detectCyclesPhase
      ) where

    import Prelude hiding (cycle)
    import qualified Data.Map as M
    import qualified Data.Set as S

    import qualified Distribution.Compat.Graph as G
    import Distribution.Simple.Utils (ordNub)
    import Distribution.Solver.Modular.Dependency
    import Distribution.Solver.Modular.Flag
    import Distribution.Solver.Modular.Tree
    import qualified Distribution.Solver.Modular.ConflictSet as CS
    import Distribution.Solver.Types.ComponentDeps (Component)
    import Distribution.Solver.Types.PackagePath

    -- | Find and reject any nodes with cyclic dependencies
    detectCyclesPhase :: Tree d c -> Tree d c
    detectCyclesPhase :: forall d c. Tree d c -> Tree d c
    detectCyclesPhase = Tree d c -> Tree d c
    forall d c. Tree d c -> Tree d c
    go
      where
        -- Only check children of choice nodes.
        go :: Tree d c -> Tree d c
        go :: forall d c. Tree d c -> Tree d c
    go (PChoice QPN
    qpn RevDepMap
    rdm c
    gr                         WeightedPSQ [Weight] POption (Tree d c)
    cs) =
            QPN
    -> RevDepMap
    -> c
    -> WeightedPSQ [Weight] POption (Tree d c)
    -> Tree d c
    forall d c.
    QPN
    -> RevDepMap
    -> c
    -> WeightedPSQ [Weight] POption (Tree d c)
    -> Tree d c
    PChoice QPN
    qpn RevDepMap
    rdm c
    gr     (WeightedPSQ [Weight] POption (Tree d c) -> Tree d c)
    -> WeightedPSQ [Weight] POption (Tree d c) -> Tree d c
    forall a b. (a -> b) -> a -> b
    $ (Tree d c -> Tree d c)
    -> WeightedPSQ [Weight] POption (Tree d c)
    -> WeightedPSQ [Weight] POption (Tree d c)
    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 (QPN -> Tree d c -> Tree d c
    forall d c. QPN -> Tree d c -> Tree d c
    checkChild QPN
    qpn)   ((Tree d c -> Tree d c)
    -> WeightedPSQ [Weight] POption (Tree d c)
    -> WeightedPSQ [Weight] POption (Tree d c)
    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 Tree d c -> Tree d c
    forall d c. Tree d c -> Tree d c
    go WeightedPSQ [Weight] POption (Tree d c)
    cs)
        go (FChoice qfn :: QFN
    qfn@(FN QPN
    qpn Flag
    _) RevDepMap
    rdm c
    gr WeakOrTrivial
    w FlagType
    m Bool
    d WeightedPSQ [Weight] Bool (Tree d c)
    cs) =
            QFN
    -> RevDepMap
    -> c
    -> WeakOrTrivial
    -> FlagType
    -> Bool
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> Tree d c
    forall d c.
    QFN
    -> RevDepMap
    -> c
    -> WeakOrTrivial
    -> FlagType
    -> Bool
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> Tree d c
    FChoice QFN
    qfn RevDepMap
    rdm c
    gr WeakOrTrivial
    w FlagType
    m Bool
    d (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
    -> WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c
    forall a b. (a -> b) -> a -> b
    $ (Tree d c -> Tree d c)
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> WeightedPSQ [Weight] Bool (Tree d c)
    forall a b.
    (a -> b)
    -> WeightedPSQ [Weight] Bool a -> WeightedPSQ [Weight] Bool b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (QPN -> Tree d c -> Tree d c
    forall d c. QPN -> Tree d c -> Tree d c
    checkChild QPN
    qpn) ((Tree d c -> Tree d c)
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> WeightedPSQ [Weight] Bool (Tree d c)
    forall a b.
    (a -> b)
    -> WeightedPSQ [Weight] Bool a -> WeightedPSQ [Weight] Bool b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Tree d c -> Tree d c
    forall d c. Tree d c -> Tree d c
    go WeightedPSQ [Weight] Bool (Tree d c)
    cs)
        go (SChoice qsn :: QSN
    qsn@(SN QPN
    qpn Stanza
    _) RevDepMap
    rdm c
    gr WeakOrTrivial
    w     WeightedPSQ [Weight] Bool (Tree d c)
    cs) =
            QSN
    -> RevDepMap
    -> c
    -> WeakOrTrivial
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> Tree d c
    forall d c.
    QSN
    -> RevDepMap
    -> c
    -> WeakOrTrivial
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> Tree d c
    SChoice QSN
    qsn RevDepMap
    rdm c
    gr WeakOrTrivial
    w   (WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c)
    -> WeightedPSQ [Weight] Bool (Tree d c) -> Tree d c
    forall a b. (a -> b) -> a -> b
    $ (Tree d c -> Tree d c)
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> WeightedPSQ [Weight] Bool (Tree d c)
    forall a b.
    (a -> b)
    -> WeightedPSQ [Weight] Bool a -> WeightedPSQ [Weight] Bool b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (QPN -> Tree d c -> Tree d c
    forall d c. QPN -> Tree d c -> Tree d c
    checkChild QPN
    qpn)   ((Tree d c -> Tree d c)
    -> WeightedPSQ [Weight] Bool (Tree d c)
    -> WeightedPSQ [Weight] Bool (Tree d c)
    forall a b.
    (a -> b)
    -> WeightedPSQ [Weight] Bool a -> WeightedPSQ [Weight] Bool b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Tree d c -> Tree d c
    forall d c. Tree d c -> Tree d c
    go WeightedPSQ [Weight] Bool (Tree d c)
    cs)
        go (GoalChoice RevDepMap
    rdm PSQ (Goal QPN) (Tree d c)
    cs) = RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
    forall d c. RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
    GoalChoice RevDepMap
    rdm ((Tree d c -> Tree d c)
    -> PSQ (Goal QPN) (Tree d c) -> PSQ (Goal QPN) (Tree d c)
    forall a b. (a -> b) -> PSQ (Goal QPN) a -> PSQ (Goal QPN) b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Tree d c -> Tree d c
    forall d c. Tree d c -> Tree d c
    go PSQ (Goal QPN) (Tree d c)
    cs)
        go x :: Tree d c
    x@(Fail ConflictSet
    _ FailReason
    _) = Tree d c
    x
        go x :: Tree d c
    x@(Done RevDepMap
    _ d
    _) = Tree d c
    x

        checkChild :: QPN -> Tree d c -> Tree d c
        checkChild :: forall d c. QPN -> Tree d c -> Tree d c
    checkChild QPN
    qpn x :: Tree d c
    x@(PChoice QPN
    _  RevDepMap
    rdm c
    _       WeightedPSQ [Weight] POption (Tree d c)
    _) = QPN -> RevDepMap -> Tree d c -> Tree d c
    forall d c. QPN -> RevDepMap -> Tree d c -> Tree d c
    failIfCycle QPN
    qpn RevDepMap
    rdm Tree d c
    x
        checkChild QPN
    qpn x :: Tree d c
    x@(FChoice QFN
    _  RevDepMap
    rdm c
    _ WeakOrTrivial
    _ FlagType
    _ Bool
    _ WeightedPSQ [Weight] Bool (Tree d c)
    _) = QPN -> RevDepMap -> Tree d c -> Tree d c
    forall d c. QPN -> RevDepMap -> Tree d c -> Tree d c
    failIfCycle QPN
    qpn RevDepMap
    rdm Tree d c
    x
        checkChild QPN
    qpn x :: Tree d c
    x@(SChoice QSN
    _  RevDepMap
    rdm c
    _ WeakOrTrivial
    _     WeightedPSQ [Weight] Bool (Tree d c)
    _) = QPN -> RevDepMap -> Tree d c -> Tree d c
    forall d c. QPN -> RevDepMap -> Tree d c -> Tree d c
    failIfCycle QPN
    qpn RevDepMap
    rdm Tree d c
    x
        checkChild QPN
    qpn x :: Tree d c
    x@(GoalChoice RevDepMap
    rdm         PSQ (Goal QPN) (Tree d c)
    _) = QPN -> RevDepMap -> Tree d c -> Tree d c
    forall d c. QPN -> RevDepMap -> Tree d c -> Tree d c
    failIfCycle QPN
    qpn RevDepMap
    rdm Tree d c
    x
        checkChild QPN
    _   x :: Tree d c
    x@(Fail ConflictSet
    _ FailReason
    _)                 = Tree d c
    x
        checkChild QPN
    qpn x :: Tree d c
    x@(Done       RevDepMap
    rdm d
    _)         = QPN -> RevDepMap -> Tree d c -> Tree d c
    forall d c. QPN -> RevDepMap -> Tree d c -> Tree d c
    failIfCycle QPN
    qpn RevDepMap
    rdm Tree d c
    x

        failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c
        failIfCycle :: forall d c. QPN -> RevDepMap -> Tree d c -> Tree d c
    failIfCycle QPN
    qpn RevDepMap
    rdm Tree d c
    x =
          case QPN -> RevDepMap -> Maybe ConflictSet
    findCycles QPN
    qpn RevDepMap
    rdm of
            Maybe ConflictSet
    Nothing     -> Tree d c
    x
            Just ConflictSet
    relSet -> ConflictSet -> FailReason -> Tree d c
    forall d c. ConflictSet -> FailReason -> Tree d c
    Fail ConflictSet
    relSet FailReason
    CyclicDependencies

    -- | Given the reverse dependency map from a node in the tree, check
    -- if the solution is cyclic. If it is, return the conflict set containing
    -- all decisions that could potentially break the cycle.
    --
    -- TODO: The conflict set should also contain flag and stanza variables.
    findCycles :: QPN -> RevDepMap -> Maybe ConflictSet
    findCycles :: QPN -> RevDepMap -> Maybe ConflictSet
    findCycles QPN
    pkg RevDepMap
    rdm =
        -- This function has two parts: a faster cycle check that is called at every
        -- step and a slower calculation of the conflict set.
        --
        -- 'hasCycle' checks for cycles incrementally by only looking for cycles
        -- containing the current package, 'pkg'. It searches for cycles in the
        -- 'RevDepMap', which is the data structure used to store reverse
        -- dependencies in the search tree. We store the reverse dependencies in a
        -- map, because Data.Map is smaller and/or has better sharing than
        -- Distribution.Compat.Graph.
        --
        -- If there is a cycle, we call G.cycles to find a strongly connected
        -- component. Then we choose one cycle from the component to use for the
        -- conflict set. Choosing only one cycle can lead to a smaller conflict set,
        -- such as when a choice to enable testing introduces many cycles at once.
        -- In that case, all cycles contain the current package and are in one large
        -- strongly connected component.
        --
        if Bool
    hasCycle
        then let scc :: G.Graph RevDepMapNode
                 scc :: Graph RevDepMapNode
    scc = case Graph RevDepMapNode -> [[RevDepMapNode]]
    forall a. Graph a -> [[a]]
    G.cycles (Graph RevDepMapNode -> [[RevDepMapNode]])
    -> Graph RevDepMapNode -> [[RevDepMapNode]]
    forall a b. (a -> b) -> a -> b
    $ RevDepMap -> Graph RevDepMapNode
    revDepMapToGraph RevDepMap
    rdm of
                         []    -> [Char] -> Graph RevDepMapNode
    forall {c}. [Char] -> c
    findCyclesError [Char]
    "cannot find a strongly connected component"
                         [RevDepMapNode]
    c : [[RevDepMapNode]]
    _ -> [RevDepMapNode] -> Graph RevDepMapNode
    forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
    G.fromDistinctList [RevDepMapNode]
    c

                 next :: QPN -> QPN
                 next :: QPN -> QPN
    next QPN
    p = case Graph RevDepMapNode -> Key RevDepMapNode -> Maybe [RevDepMapNode]
    forall a. Graph a -> Key a -> Maybe [a]
    G.neighbors Graph RevDepMapNode
    scc Key RevDepMapNode
    QPN
    p of
                            Just (RevDepMapNode
    n : [RevDepMapNode]
    _) -> RevDepMapNode -> Key RevDepMapNode
    forall a. IsNode a => a -> Key a
    G.nodeKey RevDepMapNode
    n
                            Maybe [RevDepMapNode]
    _            -> [Char] -> QPN
    forall {c}. [Char] -> c
    findCyclesError [Char]
    "cannot find next node in the cycle"

                 -- This function also assumes that all cycles contain 'pkg'.
                 oneCycle :: [QPN]
                 oneCycle :: [QPN]
    oneCycle = case (QPN -> QPN) -> QPN -> [QPN]
    forall a. (a -> a) -> a -> [a]
    iterate QPN -> QPN
    next QPN
    pkg of
                              []     -> [Char] -> [QPN]
    forall {c}. [Char] -> c
    findCyclesError [Char]
    "empty cycle"
                              QPN
    x : [QPN]
    xs -> QPN
    x QPN -> [QPN] -> [QPN]
    forall a. a -> [a] -> [a]
    : (QPN -> Bool) -> [QPN] -> [QPN]
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (QPN -> QPN -> Bool
    forall a. Eq a => a -> a -> Bool
    /= QPN
    x) [QPN]
    xs
             in ConflictSet -> Maybe ConflictSet
    forall a. a -> Maybe a
    Just (ConflictSet -> Maybe ConflictSet)
    -> ConflictSet -> Maybe ConflictSet
    forall a b. (a -> b) -> a -> b
    $ [Var QPN] -> ConflictSet
    CS.fromList ([Var QPN] -> ConflictSet) -> [Var QPN] -> ConflictSet
    forall a b. (a -> b) -> a -> b
    $ (QPN -> Var QPN) -> [QPN] -> [Var QPN]
    forall a b. (a -> b) -> [a] -> [b]
    map QPN -> Var QPN
    forall qpn. qpn -> Var qpn
    P [QPN]
    oneCycle
        else Maybe ConflictSet
    forall a. Maybe a
    Nothing
      where
        hasCycle :: Bool
        hasCycle :: Bool
    hasCycle = QPN
    pkg QPN -> Set QPN -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `S.member` [QPN] -> Set QPN
    closure (QPN -> [QPN]
    neighbors QPN
    pkg)

        closure :: [QPN] -> S.Set QPN
        closure :: [QPN] -> Set QPN
    closure = (Set QPN -> QPN -> Set QPN) -> Set QPN -> [QPN] -> Set QPN
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Set QPN -> QPN -> Set QPN
    go Set QPN
    forall a. Set a
    S.empty
          where
            go :: S.Set QPN -> QPN -> S.Set QPN
            go :: Set QPN -> QPN -> Set QPN
    go Set QPN
    s QPN
    x =
                if QPN
    x QPN -> Set QPN -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `S.member` Set QPN
    s
                then Set QPN
    s
                else (Set QPN -> QPN -> Set QPN) -> Set QPN -> [QPN] -> Set QPN
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Set QPN -> QPN -> Set QPN
    go (QPN -> Set QPN -> Set QPN
    forall a. Ord a => a -> Set a -> Set a
    S.insert QPN
    x Set QPN
    s) ([QPN] -> Set QPN) -> [QPN] -> Set QPN
    forall a b. (a -> b) -> a -> b
    $ QPN -> [QPN]
    neighbors QPN
    x

        neighbors :: QPN -> [QPN]
        neighbors :: QPN -> [QPN]
    neighbors QPN
    x = case QPN
    x QPN -> RevDepMap -> Maybe [(Component, QPN)]
    forall k a. Ord k => k -> Map k a -> Maybe a
    `M.lookup` RevDepMap
    rdm of
                        Maybe [(Component, QPN)]
    Nothing -> [Char] -> [QPN]
    forall {c}. [Char] -> c
    findCyclesError [Char]
    "cannot find node"
                        Just [(Component, QPN)]
    xs -> ((Component, QPN) -> QPN) -> [(Component, QPN)] -> [QPN]
    forall a b. (a -> b) -> [a] -> [b]
    map (Component, QPN) -> QPN
    forall a b. (a, b) -> b
    snd [(Component, QPN)]
    xs

        findCyclesError :: [Char] -> c
    findCyclesError = [Char] -> c
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> c) -> ([Char] -> [Char]) -> [Char] -> c
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([Char]
    "Distribution.Solver.Modular.Cycles.findCycles: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++)

    data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)]

    instance G.IsNode RevDepMapNode where
      type Key RevDepMapNode = QPN
      nodeKey :: RevDepMapNode -> Key RevDepMapNode
    nodeKey (RevDepMapNode QPN
    qpn [(Component, QPN)]
    _) = Key RevDepMapNode
    QPN
    qpn
      nodeNeighbors :: RevDepMapNode -> [Key RevDepMapNode]
    nodeNeighbors (RevDepMapNode QPN
    _ [(Component, QPN)]
    ns) = [Key RevDepMapNode] -> [Key RevDepMapNode]
    forall a. Ord a => [a] -> [a]
    ordNub ([Key RevDepMapNode] -> [Key RevDepMapNode])
    -> [Key RevDepMapNode] -> [Key RevDepMapNode]
    forall a b. (a -> b) -> a -> b
    $ ((Component, QPN) -> QPN) -> [(Component, QPN)] -> [QPN]
    forall a b. (a -> b) -> [a] -> [b]
    map (Component, QPN) -> QPN
    forall a b. (a, b) -> b
    snd [(Component, QPN)]
    ns

    revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode
    revDepMapToGraph :: RevDepMap -> Graph RevDepMapNode
    revDepMapToGraph RevDepMap
    rdm = [RevDepMapNode] -> Graph RevDepMapNode
    forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
    G.fromDistinctList
                           [QPN -> [(Component, QPN)] -> RevDepMapNode
    RevDepMapNode QPN
    qpn [(Component, QPN)]
    ns | (QPN
    qpn, [(Component, QPN)]
    ns) <- RevDepMap -> [(QPN, [(Component, QPN)])]
    forall k a. Map k a -> [(k, a)]
    M.toList RevDepMap
    rdm]