{-# 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 :: Tree d c -> Tree d c
detectCyclesPhase = Tree d c -> Tree d c
forall d c. Tree d c -> Tree d c
go
where
go :: Tree d c -> Tree d c
go :: 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 (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 (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 (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 (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 (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 (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 (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 :: 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 :: 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
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 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"
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 (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 (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) = [QPN] -> [QPN]
forall a. Ord a => [a] -> [a]
ordNub ([QPN] -> [QPN]) -> [QPN] -> [QPN]
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]