summaryrefslogtreecommitdiff
path: root/compiler/utils/Digraph.lhs
diff options
context:
space:
mode:
authorGabor Greif <ggreif@gmail.com>2014-08-08 18:01:19 +0200
committerGabor Greif <ggreif@gmail.com>2014-08-08 18:01:19 +0200
commit5f003d228340c3ce8e500f9053f353c58dc1dc94 (patch)
treea855b0f173ff635b48354e1136ef6cbb2a1214a4 /compiler/utils/Digraph.lhs
parentff9c5570395bcacf8963149b3a8475f5644ce694 (diff)
parentdff0623d5ab13222c06b3ff6b32793e05b417970 (diff)
downloadhaskell-wip/generics-propeq.tar.gz
Merge branch 'master' into wip/generics-propeqwip/generics-propeq
Conflicts: compiler/typecheck/TcGenGenerics.lhs
Diffstat (limited to 'compiler/utils/Digraph.lhs')
-rw-r--r--compiler/utils/Digraph.lhs79
1 files changed, 36 insertions, 43 deletions
diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs
index d22380ff6e..35782bac6e 100644
--- a/compiler/utils/Digraph.lhs
+++ b/compiler/utils/Digraph.lhs
@@ -4,13 +4,6 @@
\begin{code}
{-# LANGUAGE CPP, ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module Digraph(
Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices,
@@ -24,7 +17,7 @@ module Digraph(
componentsG,
findCycle,
-
+
-- For backwards compatability with the simpler version of Digraph
stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR,
@@ -77,14 +70,14 @@ Note [Nodes, keys, vertices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* A 'node' is a big blob of client-stuff
- * Each 'node' has a unique (client) 'key', but the latter
- is in Ord and has fast comparison
+ * Each 'node' has a unique (client) 'key', but the latter
+ is in Ord and has fast comparison
* Digraph then maps each 'key' to a Vertex (Int) which is
- arranged densely in 0.n
+ arranged densely in 0.n
\begin{code}
-data Graph node = Graph {
+data Graph node = Graph {
gr_int_graph :: IntGraph,
gr_vertex_to_node :: Vertex -> node,
gr_node_to_vertex :: node -> Maybe Vertex
@@ -92,12 +85,12 @@ data Graph node = Graph {
data Edge node = Edge node node
-type Node key payload = (payload, key, [key])
+type Node key payload = (payload, key, [key])
-- The payload is user data, just carried around in this module
-- The keys are ordered
- -- The [key] are the dependencies of the node;
+ -- The [key] are the dependencies of the node;
-- it's ok to have extra keys in the dependencies that
- -- are not the key of any Node in the graph
+ -- are not the key of any Node in the graph
emptyGraph :: Graph a
emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
@@ -105,7 +98,7 @@ emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
graphFromVerticesAndAdjacency
:: Ord key
=> [(node, key)]
- -> [(key, key)] -- First component is source vertex key,
+ -> [(key, key)] -- First component is source vertex key,
-- second is target vertex key (thing depended on)
-- Unlike the other interface I insist they correspond to
-- actual vertices because the alternative hides bugs. I can't
@@ -115,7 +108,7 @@ graphFromVerticesAndAdjacency [] _ = emptyGraph
graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor)
where key_extractor = snd
(bounds, vertex_node, key_vertex, _) = reduceNodesIntoVertices vertices key_extractor
- key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a,
+ key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a,
expectJust "graphFromVerticesAndAdjacency" $ key_vertex b)
reduced_edges = map key_vertex_pair edges
graph = buildG bounds reduced_edges
@@ -132,10 +125,10 @@ graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_
(bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor
graph = array bounds [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- numbered_nodes]
-reduceNodesIntoVertices
- :: Ord key
- => [node]
- -> (node -> key)
+reduceNodesIntoVertices
+ :: Ord key
+ => [node]
+ -> (node -> key)
-> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)])
reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes)
where
@@ -168,18 +161,18 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte
\begin{code}
type WorkItem key payload
- = (Node key payload, -- Tip of the path
- [payload]) -- Rest of the path;
- -- [a,b,c] means c depends on b, b depends on a
+ = (Node key payload, -- Tip of the path
+ [payload]) -- Rest of the path;
+ -- [a,b,c] means c depends on b, b depends on a
-- | Find a reasonably short cycle a->b->c->a, in a strongly
-- connected component. The input nodes are presumed to be
-- a SCC, so you can start anywhere.
-findCycle :: forall payload key. Ord key
+findCycle :: forall payload key. Ord key
=> [Node key payload] -- The nodes. The dependencies can
- -- contain extra keys, which are ignored
- -> Maybe [payload] -- A cycle, starting with node
- -- so each depends on the next
+ -- contain extra keys, which are ignored
+ -> Maybe [payload] -- A cycle, starting with node
+ -- so each depends on the next
findCycle graph
= go Set.empty (new_work root_deps []) []
where
@@ -189,29 +182,29 @@ findCycle graph
-- Find the node with fewest dependencies among the SCC modules
-- This is just a heuristic to find some plausible root module
root :: Node key payload
- root = fst (minWith snd [ (node, count (`Map.member` env) deps)
+ root = fst (minWith snd [ (node, count (`Map.member` env) deps)
| node@(_,_,deps) <- graph ])
(root_payload,root_key,root_deps) = root
-- 'go' implements Dijkstra's algorithm, more or less
- go :: Set.Set key -- Visited
- -> [WorkItem key payload] -- Work list, items length n
- -> [WorkItem key payload] -- Work list, items length n+1
- -> Maybe [payload] -- Returned cycle
+ go :: Set.Set key -- Visited
+ -> [WorkItem key payload] -- Work list, items length n
+ -> [WorkItem key payload] -- Work list, items length n+1
+ -> Maybe [payload] -- Returned cycle
-- Invariant: in a call (go visited ps qs),
-- visited = union (map tail (ps ++ qs))
- go _ [] [] = Nothing -- No cycles
+ go _ [] [] = Nothing -- No cycles
go visited [] qs = go visited qs []
- go visited (((payload,key,deps), path) : ps) qs
+ go visited (((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_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 ]
@@ -250,7 +243,7 @@ instance Outputable a => Outputable (SCC a) where
%************************************************************************
Note: the components are returned topologically sorted: later components
-depend on earlier ones, but not vice versa i.e. later components only have
+depend on earlier ones, but not vice versa i.e. later components only have
edges going from them to earlier ones.
\begin{code}
@@ -311,7 +304,7 @@ reachableG graph from = map (gr_vertex_to_node graph) result
reachablesG :: Graph node -> [node] -> [node]
reachablesG graph froms = map (gr_vertex_to_node graph) result
- where result = {-# SCC "Digraph.reachable" #-}
+ where result = {-# SCC "Digraph.reachable" #-}
reachable (gr_int_graph graph) vs
vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
@@ -656,18 +649,18 @@ noOutEdges g = [ v | v <- vertices g, null (g!v)]
vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]]
vertexGroupsS provided g to_provide
- = if null to_provide
- then do {
+ = if null to_provide
+ then do {
all_provided <- allM (provided `contains`) (vertices g)
; if all_provided
then return []
- else error "vertexGroup: cyclic graph"
+ else error "vertexGroup: cyclic graph"
}
- else do {
+ else do {
mapM_ (include provided) to_provide
; to_provide' <- filterM (vertexReady provided g) (vertices g)
; rest <- vertexGroupsS provided g to_provide'
- ; return $ to_provide : rest
+ ; return $ to_provide : rest
}
vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool