{-# 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 = 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) =
        forall d c.
QPN
-> RevDepMap
-> c
-> WeightedPSQ [Weight] POption (Tree d c)
-> Tree d c
PChoice QPN
qpn RevDepMap
rdm c
gr     forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall d c. QPN -> Tree d c -> Tree d c
checkChild QPN
qpn)   (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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) =
        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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall d c. QPN -> Tree d c -> Tree d c
checkChild QPN
qpn) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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) =
        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   forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall d c. QPN -> Tree d c -> Tree d c
checkChild QPN
qpn)   (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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) = forall d c. RevDepMap -> PSQ (Goal QPN) (Tree d c) -> Tree d c
GoalChoice RevDepMap
rdm (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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)
_) = 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)
_) = 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)
_) = 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)
_) = 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
_)         = 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 -> 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 forall a. Graph a -> [[a]]
G.cycles forall a b. (a -> b) -> a -> b
$ RevDepMap -> Graph RevDepMapNode
revDepMapToGraph RevDepMap
rdm of
                     []    -> forall {c}. [Char] -> c
findCyclesError [Char]
"cannot find a strongly connected component"
                     [RevDepMapNode]
c : [[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 forall a. Graph a -> Key a -> Maybe [a]
G.neighbors Graph RevDepMapNode
scc QPN
p of
                        Just (RevDepMapNode
n : [RevDepMapNode]
_) -> forall a. IsNode a => a -> Key a
G.nodeKey RevDepMapNode
n
                        Maybe [RevDepMapNode]
_            -> 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 forall a. (a -> a) -> a -> [a]
iterate QPN -> QPN
next QPN
pkg of
                          []     -> forall {c}. [Char] -> c
findCyclesError [Char]
"empty cycle"
                          QPN
x : [QPN]
xs -> QPN
x forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= QPN
x) [QPN]
xs
         in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Var QPN] -> ConflictSet
CS.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall qpn. qpn -> Var qpn
P [QPN]
oneCycle
    else forall a. Maybe a
Nothing
  where
    hasCycle :: Bool
    hasCycle :: Bool
hasCycle = QPN
pkg 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set QPN -> QPN -> Set QPN
go 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 forall a. Ord a => a -> Set a -> Bool
`S.member` Set QPN
s
            then Set QPN
s
            else forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set QPN -> QPN -> Set QPN
go (forall a. Ord a => a -> Set a -> Set a
S.insert QPN
x Set QPN
s) forall a b. (a -> b) -> a -> b
$ QPN -> [QPN]
neighbors QPN
x

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

    findCyclesError :: [Char] -> c
findCyclesError = forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"Distribution.Solver.Modular.Cycles.findCycles: " 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)]
_) = QPN
qpn
  nodeNeighbors :: RevDepMapNode -> [Key RevDepMapNode]
nodeNeighbors (RevDepMapNode QPN
_ [(Component, QPN)]
ns) = forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Component, QPN)]
ns

revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode
revDepMapToGraph :: RevDepMap -> Graph RevDepMapNode
revDepMapToGraph RevDepMap
rdm = 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) <- forall k a. Map k a -> [(k, a)]
M.toList RevDepMap
rdm]