{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GHC.Data.Graph.Directed (
Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
SCC(..), Node(..), flattenSCC, flattenSCCs,
stronglyConnCompG,
topologicalSortG,
verticesG, edgesG, hasVertexG,
reachableG, reachablesG, transposeG,
emptyG,
findCycle,
stronglyConnCompFromEdgedVerticesOrd,
stronglyConnCompFromEdgedVerticesOrdR,
stronglyConnCompFromEdgedVerticesUniq,
stronglyConnCompFromEdgedVerticesUniqR,
EdgeType(..), classifyEdges
) where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Utils.Misc ( minWith, count )
import GHC.Utils.Outputable
import GHC.Data.Maybe ( expectJust )
import Data.Maybe
import Data.Array
import Data.List hiding (transpose)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Graph as G
import Data.Graph hiding (Graph, Edge, transposeG, reachable)
import Data.Tree
import GHC.Types.Unique
import GHC.Types.Unique.FM
data Graph node = Graph {
Graph node -> IntGraph
gr_int_graph :: IntGraph,
Graph node -> Vertex -> node
gr_vertex_to_node :: Vertex -> node,
Graph node -> node -> Maybe Vertex
gr_node_to_vertex :: node -> Maybe Vertex
}
data Edge node = Edge node node
data Node key payload = DigraphNode {
Node key payload -> payload
node_payload :: payload,
Node key payload -> key
node_key :: key,
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 :: 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 :: 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 :: [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 :: [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 :: ([(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_map, key -> Maybe Vertex
key_vertex, [(Vertex, Node key payload)]
numbered_nodes)
where
max_v :: Vertex
max_v = [Node key payload] -> 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 :: 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 :: 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 :: [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 :: Graph node -> [SCC node]
stronglyConnCompG Graph node
graph = Graph node -> Forest Vertex -> [SCC node]
forall node. Graph node -> Forest Vertex -> [SCC node]
decodeSccs Graph node
graph Forest Vertex
forest
where forest :: Forest Vertex
forest = {-# SCC "Digraph.scc" #-} IntGraph -> Forest Vertex
scc (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)
decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
decodeSccs Graph { gr_int_graph :: forall node. Graph node -> IntGraph
gr_int_graph = IntGraph
graph, gr_vertex_to_node :: forall node. Graph node -> Vertex -> node
gr_vertex_to_node = Vertex -> node
vertex_fn } Forest Vertex
forest
= (Tree Vertex -> SCC node) -> Forest Vertex -> [SCC node]
forall a b. (a -> b) -> [a] -> [b]
map Tree Vertex -> SCC node
decode Forest Vertex
forest
where
decode :: Tree Vertex -> SCC node
decode (Node Vertex
v []) | Vertex -> Bool
mentions_itself Vertex
v = [node] -> SCC node
forall vertex. [vertex] -> SCC vertex
CyclicSCC [Vertex -> node
vertex_fn Vertex
v]
| Bool
otherwise = node -> SCC node
forall vertex. vertex -> SCC vertex
AcyclicSCC (Vertex -> node
vertex_fn Vertex
v)
decode Tree Vertex
other = [node] -> SCC node
forall vertex. [vertex] -> SCC vertex
CyclicSCC (Tree Vertex -> [node] -> [node]
dec Tree Vertex
other [])
where dec :: Tree Vertex -> [node] -> [node]
dec (Node Vertex
v Forest Vertex
ts) [node]
vs = Vertex -> node
vertex_fn Vertex
v node -> [node] -> [node]
forall a. a -> [a] -> [a]
: (Tree Vertex -> [node] -> [node])
-> [node] -> Forest Vertex -> [node]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tree Vertex -> [node] -> [node]
dec [node]
vs Forest Vertex
ts
mentions_itself :: Vertex -> Bool
mentions_itself Vertex
v = Vertex
v Vertex -> [Vertex] -> 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)
stronglyConnCompFromEdgedVerticesOrd
:: Ord key
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd :: [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 (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 :: [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 (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 :: [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
. 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
stronglyConnCompFromEdgedVerticesUniqR
:: Uniquable key
=> [Node key payload]
-> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR :: [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
. 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
topologicalSortG :: Graph node -> [node]
topologicalSortG :: 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]
topSort (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)
reachableG :: Graph node -> node -> [node]
reachableG :: 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]
reachablesG :: Graph node -> [node] -> [node]
reachablesG :: 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 ]
hasVertexG :: Graph node -> node -> Bool
hasVertexG :: 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 :: 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]
vertices (Graph node -> IntGraph
forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)
edgesG :: Graph node -> [Edge node]
edgesG :: 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)]
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 :: 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 :: 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
vcat [
SDoc -> Vertex -> SDoc -> SDoc
hang ([Char] -> SDoc
text [Char]
"Vertices:") Vertex
2 ([SDoc] -> SDoc
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
text [Char]
"Edges:") Vertex
2 ([SDoc] -> SDoc
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
<+> [Char] -> SDoc
text [Char]
"->" SDoc -> SDoc -> SDoc
<+> 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 :: 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
dfs IntGraph
g [Vertex]
vs)
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
/= :: EdgeType -> EdgeType -> Bool
$c/= :: EdgeType -> EdgeType -> Bool
== :: EdgeType -> EdgeType -> Bool
$c== :: 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
min :: EdgeType -> EdgeType -> EdgeType
$cmin :: EdgeType -> EdgeType -> EdgeType
max :: EdgeType -> EdgeType -> EdgeType
$cmax :: EdgeType -> EdgeType -> EdgeType
>= :: EdgeType -> EdgeType -> Bool
$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
compare :: EdgeType -> EdgeType -> Ordering
$ccompare :: EdgeType -> EdgeType -> Ordering
$cp1Ord :: Eq EdgeType
Ord)
instance Outputable EdgeType where
ppr :: EdgeType -> SDoc
ppr EdgeType
Forward = [Char] -> SDoc
text [Char]
"Forward"
ppr EdgeType
Cross = [Char] -> SDoc
text [Char]
"Cross"
ppr EdgeType
Backward = [Char] -> SDoc
text [Char]
"Backward"
ppr EdgeType
SelfLoop = [Char] -> SDoc
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
/= :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c== :: 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
min :: Time -> Time -> Time
$cmin :: Time -> Time -> Time
max :: Time -> Time -> Time
$cmax :: Time -> Time -> Time
>= :: Time -> Time -> Bool
$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
compare :: Time -> Time -> Ordering
$ccompare :: Time -> Time -> Ordering
$cp1Ord :: Eq 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
fromInteger :: Integer -> Time
$cfromInteger :: Integer -> Time
signum :: Time -> Time
$csignum :: Time -> Time
abs :: Time -> Time
$cabs :: Time -> Time
negate :: Time -> Time
$cnegate :: Time -> Time
* :: Time -> Time -> Time
$c* :: Time -> Time -> Time
- :: Time -> Time -> Time
$c- :: Time -> Time -> Time
+ :: Time -> Time -> Time
$c+ :: Time -> Time -> Time
Num,Rational -> Time -> SDoc
Time -> SDoc
(Time -> SDoc) -> (Rational -> Time -> SDoc) -> Outputable Time
forall a. (a -> SDoc) -> (Rational -> a -> SDoc) -> Outputable a
pprPrec :: Rational -> Time -> SDoc
$cpprPrec :: Rational -> Time -> SDoc
ppr :: Time -> SDoc
$cppr :: Time -> SDoc
Outputable)
{-# INLINEABLE classifyEdges #-}
classifyEdges :: forall key. Uniquable key => key -> (key -> [key])
-> [(key,key)] -> [((key, key), EdgeType)]
classifyEdges :: 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 p -> key -> p
getTime UniqFM key p
event key
node
| Just p
time <- UniqFM key p -> key -> Maybe p
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM key p
event key
node
= p
time
| Bool
otherwise
= [Char] -> SDoc -> p
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Failed to classify edge of CFG - not not timed"
([Char] -> SDoc
text [Char]
"edges" SDoc -> SDoc -> SDoc
<> (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
<+> UniqFM key Time -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqFM key Time
starts SDoc -> SDoc -> SDoc
<+> UniqFM key Time -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqFM key Time
ends )
startFrom :: Time
startFrom = UniqFM key Time -> key -> Time
forall key p. Uniquable key => UniqFM key p -> key -> p
getTime UniqFM key Time
starts key
from
startTo :: Time
startTo = UniqFM key Time -> key -> Time
forall key p. Uniquable key => UniqFM key p -> key -> p
getTime UniqFM key Time
starts key
to
endFrom :: Time
endFrom = UniqFM key Time -> key -> Time
forall key p. Uniquable key => UniqFM key p -> key -> p
getTime UniqFM key Time
ends key
from
endTo :: Time
endTo = UniqFM key Time -> key -> Time
forall key p. Uniquable key => UniqFM key p -> key -> p
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 (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'')