module Digraph(
Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
SCC(..), Node(..), flattenSCC, flattenSCCs,
stronglyConnCompG,
topologicalSortG,
verticesG, edgesG, hasVertexG,
reachableG, reachablesG, transposeG,
emptyG,
findCycle,
stronglyConnCompFromEdgedVerticesOrd,
stronglyConnCompFromEdgedVerticesOrdR,
stronglyConnCompFromEdgedVerticesUniq,
stronglyConnCompFromEdgedVerticesUniqR,
) where
#include "HsVersions.h"
import GhcPrelude
import Util ( minWith, count )
import Outputable
import Maybes ( 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 Unique
import UniqFM
data Graph node = Graph {
gr_int_graph :: IntGraph,
gr_vertex_to_node :: Vertex -> node,
gr_node_to_vertex :: node -> Maybe Vertex
}
data Edge node = Edge node node
data Node key payload = DigraphNode {
node_payload :: payload,
node_key :: key,
node_dependencies :: [key] }
instance (Outputable a, Outputable b) => Outputable (Node a b) where
ppr (DigraphNode a b c) = ppr (a, b, c)
emptyGraph :: Graph a
emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
graphFromEdgedVertices
:: ReduceFn key payload
-> [Node key payload]
-> Graph (Node key payload)
graphFromEdgedVertices _reduceFn [] = emptyGraph
graphFromEdgedVertices reduceFn edged_vertices =
Graph graph vertex_fn (key_vertex . key_extractor)
where key_extractor = node_key
(bounds, vertex_fn, key_vertex, numbered_nodes) =
reduceFn edged_vertices key_extractor
graph = array bounds [ (v, sort $ mapMaybe key_vertex ks)
| (v, (node_dependencies -> ks)) <- numbered_nodes]
graphFromEdgedVerticesOrd
:: Ord key
=> [Node key payload]
-> Graph (Node key payload)
graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd
graphFromEdgedVerticesUniq
:: Uniquable key
=> [Node key payload]
-> Graph (Node key payload)
graphFromEdgedVerticesUniq = graphFromEdgedVertices 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 fromList lookup nodes key_extractor =
(bounds, (!) vertex_map, key_vertex, numbered_nodes)
where
max_v = length nodes 1
bounds = (0, max_v) :: (Vertex, Vertex)
numbered_nodes = zip [0..] nodes
vertex_map = array bounds numbered_nodes
key_map = fromList
[ (key_extractor node, v) | (v, node) <- numbered_nodes ]
key_vertex k = lookup k key_map
reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload
reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup
reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload
reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM)
type WorkItem key payload
= (Node key payload,
[payload])
findCycle :: forall payload key. Ord key
=> [Node key payload]
-> Maybe [payload]
findCycle graph
= go Set.empty (new_work root_deps []) []
where
env :: Map.Map key (Node key payload)
env = Map.fromList [ (node_key node, node) | node <- graph ]
root :: Node key payload
root = fst (minWith snd [ (node, count (`Map.member` env)
(node_dependencies node))
| node <- graph ])
DigraphNode root_payload root_key root_deps = root
go :: Set.Set key
-> [WorkItem key payload]
-> [WorkItem key payload]
-> Maybe [payload]
go _ [] [] = Nothing
go visited [] qs = go visited qs []
go visited (((DigraphNode payload key deps), path) : ps) qs
| key == root_key = Just (root_payload : reverse path)
| key `Set.member` visited = go visited ps qs
| key `Map.notMember` env = go visited ps qs
| otherwise = go (Set.insert key visited)
ps (new_qs ++ qs)
where
new_qs = new_work deps (payload : path)
new_work :: [key] -> [payload] -> [WorkItem key payload]
new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]
stronglyConnCompG :: Graph node -> [SCC node]
stronglyConnCompG graph = decodeSccs graph forest
where forest = scc (gr_int_graph graph)
decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest
= map decode forest
where
decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
| otherwise = AcyclicSCC (vertex_fn v)
decode other = CyclicSCC (dec other [])
where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
mentions_itself v = v `elem` (graph ! v)
stronglyConnCompFromEdgedVerticesOrd
:: Ord key
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd
= map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR
stronglyConnCompFromEdgedVerticesUniq
:: Uniquable key
=> [Node key payload]
-> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq
= map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR
stronglyConnCompFromEdgedVerticesOrdR
:: Ord key
=> [Node key payload]
-> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesOrdR =
stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd
stronglyConnCompFromEdgedVerticesUniqR
:: Uniquable key
=> [Node key payload]
-> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR =
stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq
topologicalSortG :: Graph node -> [node]
topologicalSortG graph = map (gr_vertex_to_node graph) result
where result = topSort (gr_int_graph graph)
reachableG :: Graph node -> node -> [node]
reachableG graph from = map (gr_vertex_to_node graph) result
where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
result = reachable (gr_int_graph graph) [from_vertex]
reachablesG :: Graph node -> [node] -> [node]
reachablesG graph froms = map (gr_vertex_to_node graph) result
where result =
reachable (gr_int_graph graph) vs
vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
hasVertexG :: Graph node -> node -> Bool
hasVertexG graph node = isJust $ gr_node_to_vertex graph node
verticesG :: Graph node -> [node]
verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)
edgesG :: Graph node -> [Edge node]
edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)
where v2n = gr_vertex_to_node graph
transposeG :: Graph node -> Graph node
transposeG graph = Graph (G.transposeG (gr_int_graph graph))
(gr_vertex_to_node graph)
(gr_node_to_vertex graph)
emptyG :: Graph node -> Bool
emptyG g = graphEmpty (gr_int_graph g)
instance Outputable node => Outputable (Graph node) where
ppr graph = vcat [
hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),
hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))
]
instance Outputable node => Outputable (Edge node) where
ppr (Edge from to) = ppr from <+> text "->" <+> ppr to
graphEmpty :: G.Graph -> Bool
graphEmpty g = lo > hi
where (lo, hi) = bounds g
type IntGraph = G.Graph
preorderF :: Forest a -> [a]
preorderF ts = concat (map flatten ts)
reachable :: IntGraph -> [Vertex] -> [Vertex]
reachable g vs = preorderF (dfs g vs)