Remove graphFromVerticesAndAdjacency
[ghc.git] / compiler / utils / Digraph.hs
1 -- (c) The University of Glasgow 2006
2
3 {-# LANGUAGE CPP, ScopedTypeVariables #-}
4 -- For Functor SCC. ToDo: Remove me when 7.10 is released
5 {-# OPTIONS_GHC -fno-warn-orphans #-}
6 module Digraph(
7 Graph, graphFromEdgedVertices,
8
9 SCC(..), Node, flattenSCC, flattenSCCs,
10 stronglyConnCompG,
11 topologicalSortG, dfsTopSortG,
12 verticesG, edgesG, hasVertexG,
13 reachableG, reachablesG, transposeG,
14 outdegreeG, indegreeG,
15 vertexGroupsG, emptyG,
16 componentsG,
17
18 findCycle,
19
20 -- For backwards compatability with the simpler version of Digraph
21 stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR,
22 ) where
23
24 #include "HsVersions.h"
25
26 ------------------------------------------------------------------------------
27 -- A version of the graph algorithms described in:
28 --
29 -- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''
30 -- by David King and John Launchbury
31 --
32 -- Also included is some additional code for printing tree structures ...
33 --
34 -- If you ever find yourself in need of algorithms for classifying edges,
35 -- or finding connected/biconnected components, consult the history; Sigbjorn
36 -- Finne contributed some implementations in 1997, although we've since
37 -- removed them since they were not used anywhere in GHC.
38 ------------------------------------------------------------------------------
39
40
41 import Util ( minWith, count )
42 import Outputable
43 import Maybes ( expectJust )
44 import MonadUtils ( allM )
45
46 -- Extensions
47 import Control.Monad ( filterM, liftM, liftM2 )
48 import Control.Monad.ST
49
50 -- std interfaces
51 import Data.Maybe
52 import Data.Array
53 import Data.List hiding (transpose)
54 import Data.Ord
55 import Data.Array.ST
56 import qualified Data.Map as Map
57 import qualified Data.Set as Set
58
59 import qualified Data.Graph as G
60 import Data.Graph hiding (Graph, Edge, transposeG, reachable)
61 import Data.Tree
62
63 {-
64 ************************************************************************
65 * *
66 * Graphs and Graph Construction
67 * *
68 ************************************************************************
69
70 Note [Nodes, keys, vertices]
71 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
72 * A 'node' is a big blob of client-stuff
73
74 * Each 'node' has a unique (client) 'key', but the latter
75 is in Ord and has fast comparison
76
77 * Digraph then maps each 'key' to a Vertex (Int) which is
78 arranged densely in 0.n
79 -}
80
81 data Graph node = Graph {
82 gr_int_graph :: IntGraph,
83 gr_vertex_to_node :: Vertex -> node,
84 gr_node_to_vertex :: node -> Maybe Vertex
85 }
86
87 data Edge node = Edge node node
88
89 type Node key payload = (payload, key, [key])
90 -- The payload is user data, just carried around in this module
91 -- The keys are ordered
92 -- The [key] are the dependencies of the node;
93 -- it's ok to have extra keys in the dependencies that
94 -- are not the key of any Node in the graph
95
96 emptyGraph :: Graph a
97 emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
98
99 graphFromEdgedVertices
100 :: Ord key
101 => [Node key payload] -- The graph; its ok for the
102 -- out-list to contain keys which arent
103 -- a vertex key, they are ignored
104 -> Graph (Node key payload)
105 graphFromEdgedVertices [] = emptyGraph
106 graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor)
107 where key_extractor (_, k, _) = k
108 (bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor
109 graph = array bounds [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- numbered_nodes]
110
111 reduceNodesIntoVertices
112 :: Ord key
113 => [node]
114 -> (node -> key)
115 -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)])
116 reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes)
117 where
118 max_v = length nodes - 1
119 bounds = (0, max_v) :: (Vertex, Vertex)
120
121 sorted_nodes = sortBy (comparing key_extractor) nodes
122 numbered_nodes = zipWith (,) [0..] sorted_nodes
123
124 key_map = array bounds [(i, key_extractor node) | (i, node) <- numbered_nodes]
125 vertex_map = array bounds numbered_nodes
126
127 --key_vertex :: key -> Maybe Vertex
128 -- returns Nothing for non-interesting vertices
129 key_vertex k = find 0 max_v
130 where
131 find a b | a > b = Nothing
132 | otherwise = let mid = (a + b) `div` 2
133 in case compare k (key_map ! mid) of
134 LT -> find a (mid - 1)
135 EQ -> Just mid
136 GT -> find (mid + 1) b
137
138 {-
139 ************************************************************************
140 * *
141 * SCC
142 * *
143 ************************************************************************
144 -}
145
146 type WorkItem key payload
147 = (Node key payload, -- Tip of the path
148 [payload]) -- Rest of the path;
149 -- [a,b,c] means c depends on b, b depends on a
150
151 -- | Find a reasonably short cycle a->b->c->a, in a strongly
152 -- connected component. The input nodes are presumed to be
153 -- a SCC, so you can start anywhere.
154 findCycle :: forall payload key. Ord key
155 => [Node key payload] -- The nodes. The dependencies can
156 -- contain extra keys, which are ignored
157 -> Maybe [payload] -- A cycle, starting with node
158 -- so each depends on the next
159 findCycle graph
160 = go Set.empty (new_work root_deps []) []
161 where
162 env :: Map.Map key (Node key payload)
163 env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ]
164
165 -- Find the node with fewest dependencies among the SCC modules
166 -- This is just a heuristic to find some plausible root module
167 root :: Node key payload
168 root = fst (minWith snd [ (node, count (`Map.member` env) deps)
169 | node@(_,_,deps) <- graph ])
170 (root_payload,root_key,root_deps) = root
171
172
173 -- 'go' implements Dijkstra's algorithm, more or less
174 go :: Set.Set key -- Visited
175 -> [WorkItem key payload] -- Work list, items length n
176 -> [WorkItem key payload] -- Work list, items length n+1
177 -> Maybe [payload] -- Returned cycle
178 -- Invariant: in a call (go visited ps qs),
179 -- visited = union (map tail (ps ++ qs))
180
181 go _ [] [] = Nothing -- No cycles
182 go visited [] qs = go visited qs []
183 go visited (((payload,key,deps), path) : ps) qs
184 | key == root_key = Just (root_payload : reverse path)
185 | key `Set.member` visited = go visited ps qs
186 | key `Map.notMember` env = go visited ps qs
187 | otherwise = go (Set.insert key visited)
188 ps (new_qs ++ qs)
189 where
190 new_qs = new_work deps (payload : path)
191
192 new_work :: [key] -> [payload] -> [WorkItem key payload]
193 new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]
194
195 {-
196 ************************************************************************
197 * *
198 * Strongly Connected Component wrappers for Graph
199 * *
200 ************************************************************************
201
202 Note: the components are returned topologically sorted: later components
203 depend on earlier ones, but not vice versa i.e. later components only have
204 edges going from them to earlier ones.
205 -}
206
207 stronglyConnCompG :: Graph node -> [SCC node]
208 stronglyConnCompG graph = decodeSccs graph forest
209 where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph)
210
211 decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
212 decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest
213 = map decode forest
214 where
215 decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
216 | otherwise = AcyclicSCC (vertex_fn v)
217 decode other = CyclicSCC (dec other [])
218 where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
219 mentions_itself v = v `elem` (graph ! v)
220
221
222 -- The following two versions are provided for backwards compatability:
223 stronglyConnCompFromEdgedVertices
224 :: Ord key
225 => [Node key payload]
226 -> [SCC payload]
227 stronglyConnCompFromEdgedVertices
228 = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
229 where get_node (n, _, _) = n
230
231 -- The "R" interface is used when you expect to apply SCC to
232 -- (some of) the result of SCC, so you dont want to lose the dependency info
233 stronglyConnCompFromEdgedVerticesR
234 :: Ord key
235 => [Node key payload]
236 -> [SCC (Node key payload)]
237 stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices
238
239 {-
240 ************************************************************************
241 * *
242 * Misc wrappers for Graph
243 * *
244 ************************************************************************
245 -}
246
247 topologicalSortG :: Graph node -> [node]
248 topologicalSortG graph = map (gr_vertex_to_node graph) result
249 where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)
250
251 dfsTopSortG :: Graph node -> [[node]]
252 dfsTopSortG graph =
253 map (map (gr_vertex_to_node graph) . flatten) $ dfs g (topSort g)
254 where
255 g = gr_int_graph graph
256
257 reachableG :: Graph node -> node -> [node]
258 reachableG graph from = map (gr_vertex_to_node graph) result
259 where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
260 result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex]
261
262 reachablesG :: Graph node -> [node] -> [node]
263 reachablesG graph froms = map (gr_vertex_to_node graph) result
264 where result = {-# SCC "Digraph.reachable" #-}
265 reachable (gr_int_graph graph) vs
266 vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
267
268 hasVertexG :: Graph node -> node -> Bool
269 hasVertexG graph node = isJust $ gr_node_to_vertex graph node
270
271 verticesG :: Graph node -> [node]
272 verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)
273
274 edgesG :: Graph node -> [Edge node]
275 edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)
276 where v2n = gr_vertex_to_node graph
277
278 transposeG :: Graph node -> Graph node
279 transposeG graph = Graph (G.transposeG (gr_int_graph graph))
280 (gr_vertex_to_node graph)
281 (gr_node_to_vertex graph)
282
283 outdegreeG :: Graph node -> node -> Maybe Int
284 outdegreeG = degreeG outdegree
285
286 indegreeG :: Graph node -> node -> Maybe Int
287 indegreeG = degreeG indegree
288
289 degreeG :: (G.Graph -> Table Int) -> Graph node -> node -> Maybe Int
290 degreeG degree graph node = let table = degree (gr_int_graph graph)
291 in fmap ((!) table) $ gr_node_to_vertex graph node
292
293 vertexGroupsG :: Graph node -> [[node]]
294 vertexGroupsG graph = map (map (gr_vertex_to_node graph)) result
295 where result = vertexGroups (gr_int_graph graph)
296
297 emptyG :: Graph node -> Bool
298 emptyG g = graphEmpty (gr_int_graph g)
299
300 componentsG :: Graph node -> [[node]]
301 componentsG graph = map (map (gr_vertex_to_node graph) . flatten)
302 $ components (gr_int_graph graph)
303
304 {-
305 ************************************************************************
306 * *
307 * Showing Graphs
308 * *
309 ************************************************************************
310 -}
311
312 instance Outputable node => Outputable (Graph node) where
313 ppr graph = vcat [
314 hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),
315 hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))
316 ]
317
318 instance Outputable node => Outputable (Edge node) where
319 ppr (Edge from to) = ppr from <+> text "->" <+> ppr to
320
321 graphEmpty :: G.Graph -> Bool
322 graphEmpty g = lo > hi
323 where (lo, hi) = bounds g
324
325 {-
326 ************************************************************************
327 * *
328 * IntGraphs
329 * *
330 ************************************************************************
331 -}
332
333 type IntGraph = G.Graph
334
335 -- Functor instance was added in 7.8, in containers 0.5.3.2 release
336 -- ToDo: Drop me when 7.10 is released.
337 #if __GLASGOW_HASKELL__ < 708
338 instance Functor SCC where
339 fmap f (AcyclicSCC v) = AcyclicSCC (f v)
340 fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs)
341 #endif
342
343 {-
344 ------------------------------------------------------------
345 -- Depth first search numbering
346 ------------------------------------------------------------
347 -}
348
349 -- Data.Tree has flatten for Tree, but nothing for Forest
350 preorderF :: Forest a -> [a]
351 preorderF ts = concat (map flatten ts)
352
353 {-
354 ------------------------------------------------------------
355 -- Finding reachable vertices
356 ------------------------------------------------------------
357 -}
358
359 -- This generalizes reachable which was found in Data.Graph
360 reachable :: IntGraph -> [Vertex] -> [Vertex]
361 reachable g vs = preorderF (dfs g vs)
362
363 {-
364 ------------------------------------------------------------
365 -- Total ordering on groups of vertices
366 ------------------------------------------------------------
367
368 The plan here is to extract a list of groups of elements of the graph
369 such that each group has no dependence except on nodes in previous
370 groups (i.e. in particular they may not depend on nodes in their own
371 group) and is maximal such group.
372
373 Clearly we cannot provide a solution for cyclic graphs.
374
375 We proceed by iteratively removing elements with no outgoing edges
376 and their associated edges from the graph.
377
378 This probably isn't very efficient and certainly isn't very clever.
379 -}
380
381 type Set s = STArray s Vertex Bool
382
383 mkEmpty :: Bounds -> ST s (Set s)
384 mkEmpty bnds = newArray bnds False
385
386 contains :: Set s -> Vertex -> ST s Bool
387 contains m v = readArray m v
388
389 include :: Set s -> Vertex -> ST s ()
390 include m v = writeArray m v True
391
392 vertexGroups :: IntGraph -> [[Vertex]]
393 vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices)
394 where next_vertices = noOutEdges g
395
396 noOutEdges :: IntGraph -> [Vertex]
397 noOutEdges g = [ v | v <- vertices g, null (g!v)]
398
399 vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]]
400 vertexGroupsS provided g to_provide
401 = if null to_provide
402 then do {
403 all_provided <- allM (provided `contains`) (vertices g)
404 ; if all_provided
405 then return []
406 else error "vertexGroup: cyclic graph"
407 }
408 else do {
409 mapM_ (include provided) to_provide
410 ; to_provide' <- filterM (vertexReady provided g) (vertices g)
411 ; rest <- vertexGroupsS provided g to_provide'
412 ; return $ to_provide : rest
413 }
414
415 vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool
416 vertexReady provided g v = liftM2 (&&) (liftM not $ provided `contains` v) (allM (provided `contains`) (g!v))