{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.Data.Graph.Directed (
Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
graphFromVerticesAndAdjacency,
SCC(..), Node(..), G.flattenSCC, G.flattenSCCs,
stronglyConnCompG,
topologicalSortG,
verticesG, edgesG, hasVertexG,
reachableG, reachablesG, transposeG, allReachable, allReachableCyclic, outgoingG,
emptyG,
findCycle,
stronglyConnCompFromEdgedVerticesOrd,
stronglyConnCompFromEdgedVerticesOrdR,
stronglyConnCompFromEdgedVerticesUniq,
stronglyConnCompFromEdgedVerticesUniqR,
EdgeType(..), classifyEdges
) where
import GHC.Prelude
import GHC.Utils.Misc ( minWith, count )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.Maybe ( expectJust )
import Data.Maybe
import Data.Array
import Data.List ( sort )
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Graph as G
import Data.Graph ( Vertex, Bounds, SCC(..) )
import Data.Tree
import GHC.Types.Unique
import GHC.Types.Unique.FM
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.Map as M
import qualified Data.Set as S
data Graph node = Graph {
forall node. Graph node -> IntGraph
gr_int_graph :: IntGraph,
forall node. Graph node -> Vertex -> node
gr_vertex_to_node :: Vertex -> node,
forall node. Graph node -> node -> Maybe Vertex
gr_node_to_vertex :: node -> Maybe Vertex
}
data Edge node = Edge node node
data Node key payload = DigraphNode {
forall key payload. Node key payload -> payload
node_payload :: payload,
forall key payload. Node key payload -> key
node_key :: key,
forall key payload. Node key payload -> [key]
node_dependencies :: [key]
}
instance (Outputable a, Outputable b) => Outputable (Node a b) where
ppr :: Node a b -> SDoc
ppr (DigraphNode b
a a
b [a]
c) = (b, a, [a]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (b
a, a
b, [a]
c)
emptyGraph :: Graph a
emptyGraph :: forall a. Graph a
emptyGraph = IntGraph -> (Vertex -> a) -> (a -> Maybe Vertex) -> Graph a
forall node.
IntGraph
-> (Vertex -> node) -> (node -> Maybe Vertex) -> Graph node
Graph ((Vertex, Vertex) -> [(Vertex, [Vertex])] -> IntGraph
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Vertex
1, Vertex
0) []) ([Char] -> Vertex -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"emptyGraph") (Maybe Vertex -> a -> Maybe Vertex
forall a b. a -> b -> a
const Maybe Vertex
forall a. Maybe a
Nothing)
graphFromEdgedVertices
:: ReduceFn key payload
-> [Node key payload]
-> Graph (Node key payload)
graphFromEdgedVertices :: forall key payload.
ReduceFn key payload
-> [Node key payload] -> Graph (Node key payload)
graphFromEdgedVertices ReduceFn key payload
_reduceFn [] = Graph (Node key payload)
forall a. Graph a
emptyGraph
graphFromEdgedVertices ReduceFn key payload
reduceFn [Node key payload]
edged_vertices =
IntGraph
-> (Vertex -> Node key payload)
-> (Node key payload -> Maybe Vertex)
-> Graph (Node key payload)
forall node.
IntGraph
-> (Vertex -> node) -> (node -> Maybe Vertex) -> Graph node
Graph IntGraph
graph Vertex -> Node key payload
vertex_fn (key -> Maybe Vertex
key_vertex (key -> Maybe Vertex)
-> (Node key payload -> key) -> Node key payload -> Maybe Vertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node key payload -> key
forall key payload. Node key payload -> key
key_extractor)
where key_extractor :: Node key payload -> key
key_extractor = Node key payload -> key
forall key payload. Node key payload -> key
node_key
((Vertex, Vertex)
bounds, Vertex -> Node key payload
vertex_fn, key -> Maybe Vertex
key_vertex, [(Vertex, Node key payload)]
numbered_nodes) =
ReduceFn key payload
reduceFn [Node key payload]
edged_vertices Node key payload -> key
forall key payload. Node key payload -> key
key_extractor
graph :: IntGraph
graph = (Vertex, Vertex) -> [(Vertex, [Vertex])] -> IntGraph
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Vertex, Vertex)
bounds [ (Vertex
v, [Vertex] -> [Vertex]
forall a. Ord a => [a] -> [a]
sort ([Vertex] -> [Vertex]) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> a -> b
$ (key -> Maybe Vertex) -> [key] -> [Vertex]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe key -> Maybe Vertex
key_vertex [key]
ks)
| (Vertex
v, (Node key payload -> [key]
forall key payload. Node key payload -> [key]
node_dependencies -> [key]
ks)) <- [(Vertex, Node key payload)]
numbered_nodes]
graphFromEdgedVerticesOrd
:: Ord key
=> [Node key payload]
-> Graph (Node key payload)
graphFromEdgedVerticesOrd :: forall key payload.
Ord key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesOrd = ReduceFn key payload
-> [Node key payload] -> Graph (Node key payload)
forall key payload.
ReduceFn key payload
-> [Node key payload] -> Graph (Node key payload)
graphFromEdgedVertices ReduceFn key payload
forall key payload. Ord key => ReduceFn key payload
reduceNodesIntoVerticesOrd
graphFromEdgedVerticesUniq
:: Uniquable key
=> [Node key payload]
-> Graph (Node key payload)
graphFromEdgedVerticesUniq :: forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq = ReduceFn key payload
-> [Node key payload] -> Graph (Node key payload)
forall key payload.
ReduceFn key payload
-> [Node key payload] -> Graph (Node key payload)
graphFromEdgedVertices ReduceFn key payload
forall key payload. Uniquable key => ReduceFn key payload
reduceNodesIntoVerticesUniq
type ReduceFn key payload =
[Node key payload] -> (Node key payload -> key) ->
(Bounds, Vertex -> Node key payload
, key -> Maybe Vertex, [(Vertex, Node key payload)])
reduceNodesIntoVertices
:: ([(key, Vertex)] -> m)
-> (key -> m -> Maybe Vertex)
-> ReduceFn key payload
reduceNodesIntoVertices :: forall key m payload.
([(key, Vertex)] -> m)
-> (key -> m -> Maybe Vertex) -> ReduceFn key payload
reduceNodesIntoVertices [(key, Vertex)] -> m
fromList key -> m -> Maybe Vertex
lookup [Node key payload]
nodes Node key payload -> key
key_extractor =
((Vertex, Vertex)
bounds, Array Vertex (Node key payload) -> Vertex -> Node key payload
forall i e. Ix i => Array i e -> i -> e
(!) Array Vertex (Node key payload)
vertex_map, key -> Maybe Vertex
key_vertex, [(Vertex, Node key payload)]
numbered_nodes)
where
max_v :: Vertex
max_v = [Node key payload] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [Node key payload]
nodes Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
- Vertex
1
bounds :: (Vertex, Vertex)
bounds = (Vertex
0, Vertex
max_v) :: (Vertex, Vertex)
numbered_nodes :: [(Vertex, Node key payload)]
numbered_nodes = [Vertex] -> [Node key payload] -> [(Vertex, Node key payload)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Vertex
0..] [Node key payload]
nodes
vertex_map :: Array Vertex (Node key payload)
vertex_map = (Vertex, Vertex)
-> [(Vertex, Node key payload)] -> Array Vertex (Node key payload)
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Vertex, Vertex)
bounds [(Vertex, Node key payload)]
numbered_nodes
key_map :: m
key_map = [(key, Vertex)] -> m
fromList
[ (Node key payload -> key
key_extractor Node key payload
node, Vertex
v) | (Vertex
v, Node key payload
node) <- [(Vertex, Node key payload)]
numbered_nodes ]
key_vertex :: key -> Maybe Vertex
key_vertex key
k = key -> m -> Maybe Vertex
lookup key
k m
key_map
reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload
reduceNodesIntoVerticesOrd :: forall key payload. Ord key => ReduceFn key payload
reduceNodesIntoVerticesOrd = ([(key, Vertex)] -> Map key Vertex)
-> (key -> Map key Vertex -> Maybe Vertex) -> ReduceFn key payload
forall key m payload.
([(key, Vertex)] -> m)
-> (key -> m -> Maybe Vertex) -> ReduceFn key payload
reduceNodesIntoVertices [(key, Vertex)] -> Map key Vertex
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList key -> Map key Vertex -> Maybe Vertex
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup
reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload
reduceNodesIntoVerticesUniq :: forall key payload. Uniquable key => ReduceFn key payload
reduceNodesIntoVerticesUniq = ([(key, Vertex)] -> UniqFM key Vertex)
-> (key -> UniqFM key Vertex -> Maybe Vertex)
-> ReduceFn key payload
forall key m payload.
([(key, Vertex)] -> m)
-> (key -> m -> Maybe Vertex) -> ReduceFn key payload
reduceNodesIntoVertices [(key, Vertex)] -> UniqFM key Vertex
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM ((UniqFM key Vertex -> key -> Maybe Vertex)
-> key -> UniqFM key Vertex -> Maybe Vertex
forall a b c. (a -> b -> c) -> b -> a -> c
flip UniqFM key Vertex -> key -> Maybe Vertex
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM)
type WorkItem key payload
= (Node key payload,
[payload])
findCycle :: forall payload key. Ord key
=> [Node key payload]
-> Maybe [payload]
findCycle :: forall payload key.
Ord key =>
[Node key payload] -> Maybe [payload]
findCycle [Node key payload]
graph
= Set key
-> [WorkItem key payload]
-> [WorkItem key payload]
-> Maybe [payload]
go Set key
forall a. Set a
Set.empty ([key] -> [payload] -> [WorkItem key payload]
new_work [key]
root_deps []) []
where
env :: Map.Map key (Node key payload)
env :: Map key (Node key payload)
env = [(key, Node key payload)] -> Map key (Node key payload)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Node key payload -> key
forall key payload. Node key payload -> key
node_key Node key payload
node, Node key payload
node) | Node key payload
node <- [Node key payload]
graph ]
root :: Node key payload
root :: Node key payload
root = (Node key payload, Vertex) -> Node key payload
forall a b. (a, b) -> a
fst (((Node key payload, Vertex) -> Vertex)
-> [(Node key payload, Vertex)] -> (Node key payload, Vertex)
forall b a. Ord b => (a -> b) -> [a] -> a
minWith (Node key payload, Vertex) -> Vertex
forall a b. (a, b) -> b
snd [ (Node key payload
node, (key -> Bool) -> [key] -> Vertex
forall a. (a -> Bool) -> [a] -> Vertex
count (key -> Map key (Node key payload) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map key (Node key payload)
env)
(Node key payload -> [key]
forall key payload. Node key payload -> [key]
node_dependencies Node key payload
node))
| Node key payload
node <- [Node key payload]
graph ])
DigraphNode payload
root_payload key
root_key [key]
root_deps = Node key payload
root
go :: Set.Set key
-> [WorkItem key payload]
-> [WorkItem key payload]
-> Maybe [payload]
go :: Set key
-> [WorkItem key payload]
-> [WorkItem key payload]
-> Maybe [payload]
go Set key
_ [] [] = Maybe [payload]
forall a. Maybe a
Nothing
go Set key
visited [] [WorkItem key payload]
qs = Set key
-> [WorkItem key payload]
-> [WorkItem key payload]
-> Maybe [payload]
go Set key
visited [WorkItem key payload]
qs []
go Set key
visited (((DigraphNode payload
payload key
key [key]
deps), [payload]
path) : [WorkItem key payload]
ps) [WorkItem key payload]
qs
| key
key key -> key -> Bool
forall a. Eq a => a -> a -> Bool
== key
root_key = [payload] -> Maybe [payload]
forall a. a -> Maybe a
Just (payload
root_payload payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload] -> [payload]
forall a. [a] -> [a]
reverse [payload]
path)
| key
key key -> Set key -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set key
visited = Set key
-> [WorkItem key payload]
-> [WorkItem key payload]
-> Maybe [payload]
go Set key
visited [WorkItem key payload]
ps [WorkItem key payload]
qs
| key
key key -> Map key (Node key payload) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map key (Node key payload)
env = Set key
-> [WorkItem key payload]
-> [WorkItem key payload]
-> Maybe [payload]
go Set key
visited [WorkItem key payload]
ps [WorkItem key payload]
qs
| Bool
otherwise = Set key
-> [WorkItem key payload]
-> [WorkItem key payload]
-> Maybe [payload]
go (key -> Set key -> Set key
forall a. Ord a => a -> Set a -> Set a
Set.insert key
key Set key
visited)
[WorkItem key payload]
ps ([WorkItem key payload]
new_qs [WorkItem key payload]
-> [WorkItem key payload] -> [WorkItem key payload]
forall a. [a] -> [a] -> [a]
++ [WorkItem key payload]
qs)
where
new_qs :: [WorkItem key payload]
new_qs = [key] -> [payload] -> [WorkItem key payload]
new_work [key]
deps (payload
payload payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
path)
new_work :: [key] -> [payload] -> [WorkItem key payload]
new_work :: [key] -> [payload] -> [WorkItem key payload]
new_work [key]
deps [payload]
path = [ (Node key payload
n, [payload]
path) | Just Node key payload
n <- (key -> Maybe (Node key payload))
-> [key] -> [Maybe (Node key payload)]
forall a b. (a -> b) -> [a] -> [b]
map (key -> Map key (Node key payload) -> Maybe (Node key payload)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map key (Node key payload)
env) [key]
deps ]
stronglyConnCompG :: Graph node -> [SCC node]
stronglyConnCompG :: forall node. Graph node -> [SCC node]
stronglyConnCompG Graph node
graph = Graph node -> [SCC Vertex] -> [SCC node]
forall node. Graph node -> [SCC Vertex] -> [SCC node]
decodeSccs Graph node
graph ([SCC Vertex] -> [SCC node]) -> [SCC Vertex] -> [SCC node]
forall a b. (a -> b) -> a -> b
$ IntGraph -> [SCC Vertex]
scc (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)
decodeSccs :: Graph node -> [SCC Vertex] -> [SCC node]
decodeSccs :: forall node. Graph node -> [SCC Vertex] -> [SCC node]
decodeSccs Graph { gr_vertex_to_node :: forall node. Graph node -> Vertex -> node
gr_vertex_to_node = Vertex -> node
vertex_fn }
= (SCC Vertex -> SCC node) -> [SCC Vertex] -> [SCC node]
forall a b. (a -> b) -> [a] -> [b]
map ((Vertex -> node) -> SCC Vertex -> SCC node
forall a b. (a -> b) -> SCC a -> SCC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vertex -> node
vertex_fn)
stronglyConnCompFromEdgedVerticesOrd
:: Ord key
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd :: forall key payload. Ord key => [Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd
= (SCC (Node key payload) -> SCC payload)
-> [SCC (Node key payload)] -> [SCC payload]
forall a b. (a -> b) -> [a] -> [b]
map ((Node key payload -> payload)
-> SCC (Node key payload) -> SCC payload
forall a b. (a -> b) -> SCC a -> SCC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node key payload -> payload
forall key payload. Node key payload -> payload
node_payload) ([SCC (Node key payload)] -> [SCC payload])
-> ([Node key payload] -> [SCC (Node key payload)])
-> [Node key payload]
-> [SCC payload]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node key payload] -> [SCC (Node key payload)]
forall key payload.
Ord key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesOrdR
stronglyConnCompFromEdgedVerticesUniq
:: Uniquable key
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq :: forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq
= (SCC (Node key payload) -> SCC payload)
-> [SCC (Node key payload)] -> [SCC payload]
forall a b. (a -> b) -> [a] -> [b]
map ((Node key payload -> payload)
-> SCC (Node key payload) -> SCC payload
forall a b. (a -> b) -> SCC a -> SCC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node key payload -> payload
forall key payload. Node key payload -> payload
node_payload) ([SCC (Node key payload)] -> [SCC payload])
-> ([Node key payload] -> [SCC (Node key payload)])
-> [Node key payload]
-> [SCC payload]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node key payload] -> [SCC (Node key payload)]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR
stronglyConnCompFromEdgedVerticesOrdR
:: Ord key
=> [Node key payload]
-> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesOrdR :: forall key payload.
Ord key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesOrdR =
Graph (Node key payload) -> [SCC (Node key payload)]
forall node. Graph node -> [SCC node]
stronglyConnCompG (Graph (Node key payload) -> [SCC (Node key payload)])
-> ([Node key payload] -> Graph (Node key payload))
-> [Node key payload]
-> [SCC (Node key payload)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node key payload] -> Graph (Node key payload)
forall key payload.
Ord key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesOrd
stronglyConnCompFromEdgedVerticesUniqR
:: Uniquable key
=> [Node key payload]
-> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR :: forall key payload.
Uniquable key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR =
Graph (Node key payload) -> [SCC (Node key payload)]
forall node. Graph node -> [SCC node]
stronglyConnCompG (Graph (Node key payload) -> [SCC (Node key payload)])
-> ([Node key payload] -> Graph (Node key payload))
-> [Node key payload]
-> [SCC (Node key payload)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node key payload] -> Graph (Node key payload)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq
topologicalSortG :: Graph node -> [node]
topologicalSortG :: forall node. Graph node -> [node]
topologicalSortG Graph node
graph = (Vertex -> node) -> [Vertex] -> [node]
forall a b. (a -> b) -> [a] -> [b]
map (Graph node -> Vertex -> node
forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph) [Vertex]
result
where result :: [Vertex]
result = {-# SCC "Digraph.topSort" #-} IntGraph -> [Vertex]
G.topSort (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)
reachableG :: Graph node -> node -> [node]
reachableG :: forall node. Graph node -> node -> [node]
reachableG Graph node
graph node
from = (Vertex -> node) -> [Vertex] -> [node]
forall a b. (a -> b) -> [a] -> [b]
map (Graph node -> Vertex -> node
forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph) [Vertex]
result
where from_vertex :: Vertex
from_vertex = [Char] -> Maybe Vertex -> Vertex
forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"reachableG" (Graph node -> node -> Maybe Vertex
forall node. Graph node -> node -> Maybe Vertex
gr_node_to_vertex Graph node
graph node
from)
result :: [Vertex]
result = {-# SCC "Digraph.reachable" #-} IntGraph -> [Vertex] -> [Vertex]
reachable (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph) [Vertex
from_vertex]
outgoingG :: Graph node -> node -> [node]
outgoingG :: forall node. Graph node -> node -> [node]
outgoingG Graph node
graph node
from = (Vertex -> node) -> [Vertex] -> [node]
forall a b. (a -> b) -> [a] -> [b]
map (Graph node -> Vertex -> node
forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph) [Vertex]
result
where from_vertex :: Vertex
from_vertex = [Char] -> Maybe Vertex -> Vertex
forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"reachableG" (Graph node -> node -> Maybe Vertex
forall node. Graph node -> node -> Maybe Vertex
gr_node_to_vertex Graph node
graph node
from)
result :: [Vertex]
result = Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph IntGraph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
! Vertex
from_vertex
reachablesG :: Graph node -> [node] -> [node]
reachablesG :: forall node. Graph node -> [node] -> [node]
reachablesG Graph node
graph [node]
froms = (Vertex -> node) -> [Vertex] -> [node]
forall a b. (a -> b) -> [a] -> [b]
map (Graph node -> Vertex -> node
forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph) [Vertex]
result
where result :: [Vertex]
result = {-# SCC "Digraph.reachable" #-}
IntGraph -> [Vertex] -> [Vertex]
reachable (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph) [Vertex]
vs
vs :: [Vertex]
vs = [ Vertex
v | Just Vertex
v <- (node -> Maybe Vertex) -> [node] -> [Maybe Vertex]
forall a b. (a -> b) -> [a] -> [b]
map (Graph node -> node -> Maybe Vertex
forall node. Graph node -> node -> Maybe Vertex
gr_node_to_vertex Graph node
graph) [node]
froms ]
allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key)
allReachable :: forall key node.
Ord key =>
Graph node -> (node -> key) -> Map key (Set key)
allReachable = (IntGraph -> IntMap IntSet)
-> Graph node -> (node -> key) -> Map key (Set key)
forall key node.
Ord key =>
(IntGraph -> IntMap IntSet)
-> Graph node -> (node -> key) -> Map key (Set key)
all_reachable IntGraph -> IntMap IntSet
reachableGraph
allReachableCyclic :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key)
allReachableCyclic :: forall key node.
Ord key =>
Graph node -> (node -> key) -> Map key (Set key)
allReachableCyclic = (IntGraph -> IntMap IntSet)
-> Graph node -> (node -> key) -> Map key (Set key)
forall key node.
Ord key =>
(IntGraph -> IntMap IntSet)
-> Graph node -> (node -> key) -> Map key (Set key)
all_reachable IntGraph -> IntMap IntSet
reachableGraphCyclic
all_reachable :: Ord key => (IntGraph -> IM.IntMap IS.IntSet) -> Graph node -> (node -> key) -> M.Map key (S.Set key)
all_reachable :: forall key node.
Ord key =>
(IntGraph -> IntMap IntSet)
-> Graph node -> (node -> key) -> Map key (Set key)
all_reachable IntGraph -> IntMap IntSet
int_reachables (Graph IntGraph
g Vertex -> node
from node -> Maybe Vertex
_) node -> key
keyOf =
[(key, Set key)] -> Map key (Set key)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(key
k, (Vertex -> Set key -> Set key) -> Set key -> IntSet -> Set key
forall b. (Vertex -> b -> b) -> b -> IntSet -> b
IS.foldr (\Vertex
v' Set key
vs -> node -> key
keyOf (Vertex -> node
from Vertex
v') key -> Set key -> Set key
forall a. Ord a => a -> Set a -> Set a
`S.insert` Set key
vs) Set key
forall a. Set a
S.empty IntSet
vs)
| (Vertex
v, IntSet
vs) <- IntMap IntSet -> [(Vertex, IntSet)]
forall a. IntMap a -> [(Vertex, a)]
IM.toList IntMap IntSet
int_graph
, let k :: key
k = node -> key
keyOf (Vertex -> node
from Vertex
v)]
where
int_graph :: IntMap IntSet
int_graph = IntGraph -> IntMap IntSet
int_reachables IntGraph
g
hasVertexG :: Graph node -> node -> Bool
hasVertexG :: forall node. Graph node -> node -> Bool
hasVertexG Graph node
graph node
node = Maybe Vertex -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Vertex -> Bool) -> Maybe Vertex -> Bool
forall a b. (a -> b) -> a -> b
$ Graph node -> node -> Maybe Vertex
forall node. Graph node -> node -> Maybe Vertex
gr_node_to_vertex Graph node
graph node
node
verticesG :: Graph node -> [node]
verticesG :: forall node. Graph node -> [node]
verticesG Graph node
graph = (Vertex -> node) -> [Vertex] -> [node]
forall a b. (a -> b) -> [a] -> [b]
map (Graph node -> Vertex -> node
forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph) ([Vertex] -> [node]) -> [Vertex] -> [node]
forall a b. (a -> b) -> a -> b
$ IntGraph -> [Vertex]
G.vertices (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)
edgesG :: Graph node -> [Edge node]
edgesG :: forall node. Graph node -> [Edge node]
edgesG Graph node
graph = ((Vertex, Vertex) -> Edge node)
-> [(Vertex, Vertex)] -> [Edge node]
forall a b. (a -> b) -> [a] -> [b]
map (\(Vertex
v1, Vertex
v2) -> node -> node -> Edge node
forall node. node -> node -> Edge node
Edge (Vertex -> node
v2n Vertex
v1) (Vertex -> node
v2n Vertex
v2)) ([(Vertex, Vertex)] -> [Edge node])
-> [(Vertex, Vertex)] -> [Edge node]
forall a b. (a -> b) -> a -> b
$ IntGraph -> [(Vertex, Vertex)]
G.edges (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)
where v2n :: Vertex -> node
v2n = Graph node -> Vertex -> node
forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph
transposeG :: Graph node -> Graph node
transposeG :: forall node. Graph node -> Graph node
transposeG Graph node
graph = IntGraph
-> (Vertex -> node) -> (node -> Maybe Vertex) -> Graph node
forall node.
IntGraph
-> (Vertex -> node) -> (node -> Maybe Vertex) -> Graph node
Graph (IntGraph -> IntGraph
G.transposeG (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph))
(Graph node -> Vertex -> node
forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph)
(Graph node -> node -> Maybe Vertex
forall node. Graph node -> node -> Maybe Vertex
gr_node_to_vertex Graph node
graph)
emptyG :: Graph node -> Bool
emptyG :: forall node. Graph node -> Bool
emptyG Graph node
g = IntGraph -> Bool
graphEmpty (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
g)
instance Outputable node => Outputable (Graph node) where
ppr :: Graph node -> SDoc
ppr Graph node
graph = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [
SDoc -> Vertex -> SDoc -> SDoc
hang ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Vertices:") Vertex
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((node -> SDoc) -> [node] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map node -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([node] -> [SDoc]) -> [node] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ Graph node -> [node]
forall node. Graph node -> [node]
verticesG Graph node
graph)),
SDoc -> Vertex -> SDoc -> SDoc
hang ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Edges:") Vertex
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((Edge node -> SDoc) -> [Edge node] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Edge node -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Edge node] -> [SDoc]) -> [Edge node] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ Graph node -> [Edge node]
forall node. Graph node -> [Edge node]
edgesG Graph node
graph))
]
instance Outputable node => Outputable (Edge node) where
ppr :: Edge node -> SDoc
ppr (Edge node
from node
to) = node -> SDoc
forall a. Outputable a => a -> SDoc
ppr node
from SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> node -> SDoc
forall a. Outputable a => a -> SDoc
ppr node
to
graphEmpty :: G.Graph -> Bool
graphEmpty :: IntGraph -> Bool
graphEmpty IntGraph
g = Vertex
lo Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
> Vertex
hi
where (Vertex
lo, Vertex
hi) = IntGraph -> (Vertex, Vertex)
forall i e. Array i e -> (i, i)
bounds IntGraph
g
type IntGraph = G.Graph
preorderF :: Forest a -> [a]
preorderF :: forall a. Forest a -> [a]
preorderF Forest a
ts = (Tree a -> [a]) -> Forest a -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [a]
forall a. Tree a -> [a]
flatten Forest a
ts
reachable :: IntGraph -> [Vertex] -> [Vertex]
reachable :: IntGraph -> [Vertex] -> [Vertex]
reachable IntGraph
g [Vertex]
vs = Forest Vertex -> [Vertex]
forall a. Forest a -> [a]
preorderF (IntGraph -> [Vertex] -> Forest Vertex
G.dfs IntGraph
g [Vertex]
vs)
reachableGraph :: IntGraph -> IM.IntMap IS.IntSet
reachableGraph :: IntGraph -> IntMap IntSet
reachableGraph IntGraph
g = IntMap IntSet
res
where
do_one :: Vertex -> IntSet
do_one Vertex
v = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions ([Vertex] -> IntSet
IS.fromList (IntGraph
g IntGraph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
! Vertex
v) IntSet -> [IntSet] -> [IntSet]
forall a. a -> [a] -> [a]
: (Vertex -> Maybe IntSet) -> [Vertex] -> [IntSet]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Vertex -> IntMap IntSet -> Maybe IntSet)
-> IntMap IntSet -> Vertex -> Maybe IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vertex -> IntMap IntSet -> Maybe IntSet
forall a. Vertex -> IntMap a -> Maybe a
IM.lookup IntMap IntSet
res) (IntGraph
g IntGraph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
! Vertex
v))
res :: IntMap IntSet
res = [(Vertex, IntSet)] -> IntMap IntSet
forall a. [(Vertex, a)] -> IntMap a
IM.fromList [(Vertex
v, Vertex -> IntSet
do_one Vertex
v) | Vertex
v <- IntGraph -> [Vertex]
G.vertices IntGraph
g]
scc :: IntGraph -> [SCC Vertex]
scc :: IntGraph -> [SCC Vertex]
scc IntGraph
graph = (Tree Vertex -> SCC Vertex) -> Forest Vertex -> [SCC Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Tree Vertex -> SCC Vertex
decode Forest Vertex
forest
where
forest :: Forest Vertex
forest = {-# SCC "Digraph.scc" #-} IntGraph -> Forest Vertex
G.scc IntGraph
graph
decode :: Tree Vertex -> SCC Vertex
decode (Node Vertex
v []) | Vertex -> Bool
mentions_itself Vertex
v = [Vertex] -> SCC Vertex
forall vertex. [vertex] -> SCC vertex
CyclicSCC [Vertex
v]
| Bool
otherwise = Vertex -> SCC Vertex
forall vertex. vertex -> SCC vertex
AcyclicSCC Vertex
v
decode Tree Vertex
other = [Vertex] -> SCC Vertex
forall vertex. [vertex] -> SCC vertex
CyclicSCC (Tree Vertex -> [Vertex] -> [Vertex]
forall {a}. Tree a -> [a] -> [a]
dec Tree Vertex
other [])
where dec :: Tree a -> [a] -> [a]
dec (Node a
v [Tree a]
ts) [a]
vs = a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (Tree a -> [a] -> [a]) -> [a] -> [Tree a] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tree a -> [a] -> [a]
dec [a]
vs [Tree a]
ts
mentions_itself :: Vertex -> Bool
mentions_itself Vertex
v = Vertex
v Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (IntGraph
graph IntGraph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
! Vertex
v)
reachableGraphCyclic :: IntGraph -> IM.IntMap IS.IntSet
reachableGraphCyclic :: IntGraph -> IntMap IntSet
reachableGraphCyclic IntGraph
g = (IntMap IntSet -> SCC Vertex -> IntMap IntSet)
-> IntMap IntSet -> [SCC Vertex] -> IntMap IntSet
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntMap IntSet -> SCC Vertex -> IntMap IntSet
add_one_comp IntMap IntSet
forall a. Monoid a => a
mempty [SCC Vertex]
comps
where
neighboursOf :: Vertex -> [Vertex]
neighboursOf Vertex
v = IntGraph
gIntGraph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
!Vertex
v
comps :: [SCC Vertex]
comps = IntGraph -> [SCC Vertex]
scc IntGraph
g
add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet
add_one_comp :: IntMap IntSet -> SCC Vertex -> IntMap IntSet
add_one_comp IntMap IntSet
earlier (AcyclicSCC Vertex
v) = Vertex -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. Vertex -> a -> IntMap a -> IntMap a
IM.insert Vertex
v IntSet
all_remotes IntMap IntSet
earlier
where
earlier_neighbours :: [Vertex]
earlier_neighbours = Vertex -> [Vertex]
neighboursOf Vertex
v
earlier_further :: [IntSet]
earlier_further = (Vertex -> Maybe IntSet) -> [Vertex] -> [IntSet]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Vertex -> IntMap IntSet -> Maybe IntSet)
-> IntMap IntSet -> Vertex -> Maybe IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vertex -> IntMap IntSet -> Maybe IntSet
forall a. Vertex -> IntMap a -> Maybe a
IM.lookup IntMap IntSet
earlier) [Vertex]
earlier_neighbours
all_remotes :: IntSet
all_remotes = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions ([Vertex] -> IntSet
IS.fromList [Vertex]
earlier_neighbours IntSet -> [IntSet] -> [IntSet]
forall a. a -> [a] -> [a]
: [IntSet]
earlier_further)
add_one_comp IntMap IntSet
earlier (CyclicSCC [Vertex]
vs) = IntMap IntSet -> IntMap IntSet -> IntMap IntSet
forall a. IntMap a -> IntMap a -> IntMap a
IM.union ([(Vertex, IntSet)] -> IntMap IntSet
forall a. [(Vertex, a)] -> IntMap a
IM.fromList [(Vertex
v, Vertex -> IntSet
local Vertex
v IntSet -> IntSet -> IntSet
`IS.union` IntSet
all_remotes) | Vertex
v <- [Vertex]
vs]) IntMap IntSet
earlier
where
all_locals :: IntSet
all_locals = [Vertex] -> IntSet
IS.fromList [Vertex]
vs
local :: Vertex -> IntSet
local Vertex
v = Vertex -> IntSet -> IntSet
IS.delete Vertex
v IntSet
all_locals
all_neighbours :: IntSet
all_neighbours = [Vertex] -> IntSet
IS.fromList ((Vertex -> [Vertex]) -> [Vertex] -> [Vertex]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Vertex -> [Vertex]
neighboursOf [Vertex]
vs)
earlier_neighbours :: IntSet
earlier_neighbours = IntSet
all_neighbours IntSet -> IntSet -> IntSet
IS.\\ IntSet
all_locals
earlier_further :: [IntSet]
earlier_further = (Vertex -> Maybe IntSet) -> [Vertex] -> [IntSet]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Vertex -> IntMap IntSet -> Maybe IntSet)
-> IntMap IntSet -> Vertex -> Maybe IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vertex -> IntMap IntSet -> Maybe IntSet
forall a. Vertex -> IntMap a -> Maybe a
IM.lookup IntMap IntSet
earlier) (IntSet -> [Vertex]
IS.toList IntSet
earlier_neighbours)
all_remotes :: IntSet
all_remotes = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions (IntSet
earlier_neighbours IntSet -> [IntSet] -> [IntSet]
forall a. a -> [a] -> [a]
: [IntSet]
earlier_further)
data EdgeType
= Forward
| Cross
| Backward
| SelfLoop
deriving (EdgeType -> EdgeType -> Bool
(EdgeType -> EdgeType -> Bool)
-> (EdgeType -> EdgeType -> Bool) -> Eq EdgeType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeType -> EdgeType -> Bool
== :: EdgeType -> EdgeType -> Bool
$c/= :: EdgeType -> EdgeType -> Bool
/= :: EdgeType -> EdgeType -> Bool
Eq,Eq EdgeType
Eq EdgeType =>
(EdgeType -> EdgeType -> Ordering)
-> (EdgeType -> EdgeType -> Bool)
-> (EdgeType -> EdgeType -> Bool)
-> (EdgeType -> EdgeType -> Bool)
-> (EdgeType -> EdgeType -> Bool)
-> (EdgeType -> EdgeType -> EdgeType)
-> (EdgeType -> EdgeType -> EdgeType)
-> Ord EdgeType
EdgeType -> EdgeType -> Bool
EdgeType -> EdgeType -> Ordering
EdgeType -> EdgeType -> EdgeType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: EdgeType -> EdgeType -> Ordering
compare :: EdgeType -> EdgeType -> Ordering
$c< :: EdgeType -> EdgeType -> Bool
< :: EdgeType -> EdgeType -> Bool
$c<= :: EdgeType -> EdgeType -> Bool
<= :: EdgeType -> EdgeType -> Bool
$c> :: EdgeType -> EdgeType -> Bool
> :: EdgeType -> EdgeType -> Bool
$c>= :: EdgeType -> EdgeType -> Bool
>= :: EdgeType -> EdgeType -> Bool
$cmax :: EdgeType -> EdgeType -> EdgeType
max :: EdgeType -> EdgeType -> EdgeType
$cmin :: EdgeType -> EdgeType -> EdgeType
min :: EdgeType -> EdgeType -> EdgeType
Ord)
instance Outputable EdgeType where
ppr :: EdgeType -> SDoc
ppr EdgeType
Forward = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Forward"
ppr EdgeType
Cross = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Cross"
ppr EdgeType
Backward = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Backward"
ppr EdgeType
SelfLoop = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"SelfLoop"
newtype Time = Time Int deriving (Time -> Time -> Bool
(Time -> Time -> Bool) -> (Time -> Time -> Bool) -> Eq Time
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
/= :: Time -> Time -> Bool
Eq,Eq Time
Eq Time =>
(Time -> Time -> Ordering)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Time)
-> (Time -> Time -> Time)
-> Ord Time
Time -> Time -> Bool
Time -> Time -> Ordering
Time -> Time -> Time
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Time -> Time -> Ordering
compare :: Time -> Time -> Ordering
$c< :: Time -> Time -> Bool
< :: Time -> Time -> Bool
$c<= :: Time -> Time -> Bool
<= :: Time -> Time -> Bool
$c> :: Time -> Time -> Bool
> :: Time -> Time -> Bool
$c>= :: Time -> Time -> Bool
>= :: Time -> Time -> Bool
$cmax :: Time -> Time -> Time
max :: Time -> Time -> Time
$cmin :: Time -> Time -> Time
min :: Time -> Time -> Time
Ord,Integer -> Time
Time -> Time
Time -> Time -> Time
(Time -> Time -> Time)
-> (Time -> Time -> Time)
-> (Time -> Time -> Time)
-> (Time -> Time)
-> (Time -> Time)
-> (Time -> Time)
-> (Integer -> Time)
-> Num Time
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: Time -> Time -> Time
+ :: Time -> Time -> Time
$c- :: Time -> Time -> Time
- :: Time -> Time -> Time
$c* :: Time -> Time -> Time
* :: Time -> Time -> Time
$cnegate :: Time -> Time
negate :: Time -> Time
$cabs :: Time -> Time
abs :: Time -> Time
$csignum :: Time -> Time
signum :: Time -> Time
$cfromInteger :: Integer -> Time
fromInteger :: Integer -> Time
Num,Time -> SDoc
(Time -> SDoc) -> Outputable Time
forall a. (a -> SDoc) -> Outputable a
$cppr :: Time -> SDoc
ppr :: Time -> SDoc
Outputable)
{-# INLINEABLE classifyEdges #-}
classifyEdges :: forall key. Uniquable key => key -> (key -> [key])
-> [(key,key)] -> [((key, key), EdgeType)]
classifyEdges :: forall key.
Uniquable key =>
key -> (key -> [key]) -> [(key, key)] -> [((key, key), EdgeType)]
classifyEdges key
root key -> [key]
getSucc [(key, key)]
edges =
[(key, key)] -> [EdgeType] -> [((key, key), EdgeType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(key, key)]
edges ([EdgeType] -> [((key, key), EdgeType)])
-> [EdgeType] -> [((key, key), EdgeType)]
forall a b. (a -> b) -> a -> b
$ ((key, key) -> EdgeType) -> [(key, key)] -> [EdgeType]
forall a b. (a -> b) -> [a] -> [b]
map (key, key) -> EdgeType
classify [(key, key)]
edges
where
(Time
_time, UniqFM key Time
starts, UniqFM key Time
ends) = (Time, UniqFM key Time, UniqFM key Time)
-> key -> (Time, UniqFM key Time, UniqFM key Time)
addTimes (Time
0,UniqFM key Time
forall key elt. UniqFM key elt
emptyUFM,UniqFM key Time
forall key elt. UniqFM key elt
emptyUFM) key
root
classify :: (key,key) -> EdgeType
classify :: (key, key) -> EdgeType
classify (key
from,key
to)
| Time
startFrom Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
startTo
, Time
endFrom Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
endTo
= EdgeType
Forward
| Time
startFrom Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
startTo
, Time
endFrom Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
endTo
= EdgeType
Backward
| Time
startFrom Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
startTo
, Time
endFrom Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
endTo
= EdgeType
Cross
| key -> Unique
forall a. Uniquable a => a -> Unique
getUnique key
from Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== key -> Unique
forall a. Uniquable a => a -> Unique
getUnique key
to
= EdgeType
SelfLoop
| Bool
otherwise
= [Char] -> SDoc -> EdgeType
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Failed to classify edge of Graph"
((Unique, Unique) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (key -> Unique
forall a. Uniquable a => a -> Unique
getUnique key
from, key -> Unique
forall a. Uniquable a => a -> Unique
getUnique key
to))
where
getTime :: UniqFM key Time -> key -> Time
getTime UniqFM key Time
event key
node
| Just Time
time <- UniqFM key Time -> key -> Maybe Time
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM key Time
event key
node
= Time
time
| Bool
otherwise
= [Char] -> SDoc -> Time
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Failed to classify edge of CFG - not not timed"
([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"edges" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> (Unique, Unique) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (key -> Unique
forall a. Uniquable a => a -> Unique
getUnique key
from, key -> Unique
forall a. Uniquable a => a -> Unique
getUnique key
to)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UniqFM key Time -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqFM key Time
starts SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UniqFM key Time -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqFM key Time
ends )
startFrom :: Time
startFrom = UniqFM key Time -> key -> Time
getTime UniqFM key Time
starts key
from
startTo :: Time
startTo = UniqFM key Time -> key -> Time
getTime UniqFM key Time
starts key
to
endFrom :: Time
endFrom = UniqFM key Time -> key -> Time
getTime UniqFM key Time
ends key
from
endTo :: Time
endTo = UniqFM key Time -> key -> Time
getTime UniqFM key Time
ends key
to
addTimes :: (Time, UniqFM key Time, UniqFM key Time) -> key
-> (Time, UniqFM key Time, UniqFM key Time)
addTimes :: (Time, UniqFM key Time, UniqFM key Time)
-> key -> (Time, UniqFM key Time, UniqFM key Time)
addTimes (Time
time,UniqFM key Time
starts,UniqFM key Time
ends) key
n
| key -> UniqFM key Time -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
elemUFM key
n UniqFM key Time
starts
= (Time
time,UniqFM key Time
starts,UniqFM key Time
ends)
| Bool
otherwise =
let
starts' :: UniqFM key Time
starts' = UniqFM key Time -> key -> Time -> UniqFM key Time
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM key Time
starts key
n Time
time
time' :: Time
time' = Time
time Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
1
succs :: [key]
succs = key -> [key]
getSucc key
n :: [key]
(Time
time'',UniqFM key Time
starts'',UniqFM key Time
ends') = ((Time, UniqFM key Time, UniqFM key Time)
-> key -> (Time, UniqFM key Time, UniqFM key Time))
-> (Time, UniqFM key Time, UniqFM key Time)
-> [key]
-> (Time, UniqFM key Time, UniqFM key Time)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Time, UniqFM key Time, UniqFM key Time)
-> key -> (Time, UniqFM key Time, UniqFM key Time)
addTimes (Time
time',UniqFM key Time
starts',UniqFM key Time
ends) [key]
succs
ends'' :: UniqFM key Time
ends'' = UniqFM key Time -> key -> Time -> UniqFM key Time
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM key Time
ends' key
n Time
time''
in
(Time
time'' Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
1, UniqFM key Time
starts'', UniqFM key Time
ends'')
graphFromVerticesAndAdjacency
:: Ord key
=> [Node key payload]
-> [(key, key)]
-> Graph (Node key payload)
graphFromVerticesAndAdjacency :: forall key payload.
Ord key =>
[Node key payload] -> [(key, key)] -> Graph (Node key payload)
graphFromVerticesAndAdjacency [] [(key, key)]
_ = Graph (Node key payload)
forall a. Graph a
emptyGraph
graphFromVerticesAndAdjacency [Node key payload]
vertices [(key, key)]
edges = IntGraph
-> (Vertex -> Node key payload)
-> (Node key payload -> Maybe Vertex)
-> Graph (Node key payload)
forall node.
IntGraph
-> (Vertex -> node) -> (node -> Maybe Vertex) -> Graph node
Graph IntGraph
graph Vertex -> Node key payload
vertex_node (key -> Maybe Vertex
key_vertex (key -> Maybe Vertex)
-> (Node key payload -> key) -> Node key payload -> Maybe Vertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node key payload -> key
forall key payload. Node key payload -> key
key_extractor)
where key_extractor :: Node key payload -> key
key_extractor = Node key payload -> key
forall key payload. Node key payload -> key
node_key
((Vertex, Vertex)
bounds, Vertex -> Node key payload
vertex_node, key -> Maybe Vertex
key_vertex, [(Vertex, Node key payload)]
_) = ReduceFn key payload
forall key payload. Ord key => ReduceFn key payload
reduceNodesIntoVerticesOrd [Node key payload]
vertices Node key payload -> key
forall key payload. Node key payload -> key
key_extractor
key_vertex_pair :: (key, key) -> (Vertex, Vertex)
key_vertex_pair (key
a, key
b) = ([Char] -> Maybe Vertex -> Vertex
forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"graphFromVerticesAndAdjacency" (Maybe Vertex -> Vertex) -> Maybe Vertex -> Vertex
forall a b. (a -> b) -> a -> b
$ key -> Maybe Vertex
key_vertex key
a,
[Char] -> Maybe Vertex -> Vertex
forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"graphFromVerticesAndAdjacency" (Maybe Vertex -> Vertex) -> Maybe Vertex -> Vertex
forall a b. (a -> b) -> a -> b
$ key -> Maybe Vertex
key_vertex key
b)
reduced_edges :: [(Vertex, Vertex)]
reduced_edges = ((key, key) -> (Vertex, Vertex))
-> [(key, key)] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> [a] -> [b]
map (key, key) -> (Vertex, Vertex)
key_vertex_pair [(key, key)]
edges
graph :: IntGraph
graph = (Vertex, Vertex) -> [(Vertex, Vertex)] -> IntGraph
G.buildG (Vertex, Vertex)
bounds [(Vertex, Vertex)]
reduced_edges