{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
module GHC.Data.Graph.Directed (
Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
graphFromVerticesAndAdjacency, emptyGraph,
SCC(..), Node(..), G.flattenSCC, G.flattenSCCs,
stronglyConnCompG,
topologicalSortG,
verticesG, edgesG, hasVertexG,
reachablesG,
transposeG, outgoingG,
emptyG,
findCycle,
stronglyConnCompFromEdgedVerticesOrd,
stronglyConnCompFromEdgedVerticesOrdR,
stronglyConnCompFromEdgedVerticesUniq,
stronglyConnCompFromEdgedVerticesUniqR,
EdgeType(..), classifyEdges
) where
import GHC.Prelude
import GHC.Utils.Misc ( sortWith, 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 GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Data.Graph.Directed.Internal
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]
} deriving (forall a b. (a -> b) -> Node key a -> Node key b)
-> (forall a b. a -> Node key b -> Node key a)
-> Functor (Node key)
forall a b. a -> Node key b -> Node key a
forall a b. (a -> b) -> Node key a -> Node key b
forall key a b. a -> Node key b -> Node key a
forall key a b. (a -> b) -> Node key a -> Node key b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall key a b. (a -> b) -> Node key a -> Node key b
fmap :: forall a b. (a -> b) -> Node key a -> Node key b
$c<$ :: forall key a b. a -> Node key b -> Node key a
<$ :: forall a b. a -> Node key b -> Node key a
Functor
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
= [Node key payload] -> Maybe [payload]
goRoots [Node key payload]
plausible_roots
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 ]
goRoots :: [Node key payload] -> Maybe [payload]
goRoots [] = Maybe [payload]
forall a. Maybe a
Nothing
goRoots (Node key payload
root:[Node key payload]
xs) =
case 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 []) [] of
Maybe [payload]
Nothing -> [Node key payload] -> Maybe [payload]
goRoots [Node key payload]
xs
Just [payload]
res -> [payload] -> Maybe [payload]
forall a. a -> Maybe a
Just [payload]
res
where
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)
plausible_roots :: [Node key payload]
plausible_roots :: [Node key payload]
plausible_roots = ((Node key payload, Vertex) -> Node key payload)
-> [(Node key payload, Vertex)] -> [Node key payload]
forall a b. (a -> b) -> [a] -> [b]
map (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]
sortWith (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 ])
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)
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. HasDebugCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"outgoingG" (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 ]
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
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)
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
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 {k} (key :: k) elt. UniqFM key elt
emptyUFM,UniqFM key Time
forall {k} (key :: k) 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. HasDebugCallStack => [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. HasDebugCallStack => [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