diff options
author | Gabor Greif <ggreif@gmail.com> | 2014-08-08 18:01:19 +0200 |
---|---|---|
committer | Gabor Greif <ggreif@gmail.com> | 2014-08-08 18:01:19 +0200 |
commit | 5f003d228340c3ce8e500f9053f353c58dc1dc94 (patch) | |
tree | a855b0f173ff635b48354e1136ef6cbb2a1214a4 /compiler/utils/Digraph.lhs | |
parent | ff9c5570395bcacf8963149b3a8475f5644ce694 (diff) | |
parent | dff0623d5ab13222c06b3ff6b32793e05b417970 (diff) | |
download | haskell-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.lhs | 79 |
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 |