{-# 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
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
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
findCycles :: QPN -> RevDepMap -> Maybe ConflictSet
findCycles :: QPN -> RevDepMap -> Maybe ConflictSet
findCycles QPN
pkg RevDepMap
rdm =
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"
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]