-- (c) The University of Glasgow 2006 {-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Digraph( Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, SCC(..), Node(..), flattenSCC, flattenSCCs, stronglyConnCompG, topologicalSortG, verticesG, edgesG, hasVertexG, reachableG, reachablesG, transposeG, emptyG, findCycle, -- For backwards compatibility with the simpler version of Digraph stronglyConnCompFromEdgedVerticesOrd, stronglyConnCompFromEdgedVerticesOrdR, stronglyConnCompFromEdgedVerticesUniq, stronglyConnCompFromEdgedVerticesUniqR, -- Simple way to classify edges EdgeType(..), classifyEdges ) where #include "HsVersions.h" ------------------------------------------------------------------------------ -- A version of the graph algorithms described in: -- -- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell'' -- by David King and John Launchbury -- -- Also included is some additional code for printing tree structures ... -- -- If you ever find yourself in need of algorithms for classifying edges, -- or finding connected/biconnected components, consult the history; Sigbjorn -- Finne contributed some implementations in 1997, although we've since -- removed them since they were not used anywhere in GHC. ------------------------------------------------------------------------------ import GhcPrelude import Util ( minWith, count ) import Outputable import Maybes ( expectJust ) -- std interfaces 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 {- ************************************************************************ * * * Graphs and Graph Construction * * ************************************************************************ 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 * Digraph then maps each 'key' to a Vertex (Int) which is arranged densely in 0.n -} data Graph node = Graph { Graph node -> IntGraph gr_int_graph :: IntGraph, Graph node -> Vertex -> node gr_vertex_to_node :: Vertex -> node, Graph node -> node -> Maybe Vertex gr_node_to_vertex :: node -> Maybe Vertex } data Edge node = Edge node node {-| Representation for nodes of the Graph. * The @payload@ is user data, just carried around in this module * The @key@ is the node identifier. Key has an Ord instance for performance reasons. * 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 -} data Node key payload = DigraphNode { Node key payload -> payload node_payload :: payload, -- ^ User data Node key payload -> key node_key :: key, -- ^ User defined node id Node key payload -> [key] node_dependencies :: [key] -- ^ Dependencies/successors of the node } 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 :: 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) -- See Note [Deterministic SCC] graphFromEdgedVertices :: ReduceFn key payload -> [Node key payload] -- The graph; its ok for the -- out-list to contain keys which aren't -- a vertex key, they are ignored -> Graph (Node key payload) graphFromEdgedVertices :: 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] -- We normalize outgoing edges by sorting on node order, so -- that the result doesn't depend on the order of the edges -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] graphFromEdgedVerticesOrd :: Ord key => [Node key payload] -- The graph; its ok for the -- out-list to contain keys which aren't -- a vertex key, they are ignored -> Graph (Node key payload) graphFromEdgedVerticesOrd :: [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 -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] graphFromEdgedVerticesUniq :: Uniquable key => [Node key payload] -- The graph; its ok for the -- out-list to contain keys which aren't -- a vertex key, they are ignored -> Graph (Node key payload) graphFromEdgedVerticesUniq :: [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)]) {- Note [reduceNodesIntoVertices implementations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ reduceNodesIntoVertices is parameterized by the container type. This is to accomodate key types that don't have an Ord instance and hence preclude the use of Data.Map. An example of such type would be Unique, there's no way to implement Ord Unique deterministically. For such types, there's a version with a Uniquable constraint. This leaves us with two versions of every function that depends on reduceNodesIntoVertices, one with Ord constraint and the other with Uniquable constraint. For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq. The Uniq version should be a tiny bit more efficient since it uses Data.IntMap internally. -} reduceNodesIntoVertices :: ([(key, Vertex)] -> m) -> (key -> m -> Maybe Vertex) -> ReduceFn key payload reduceNodesIntoVertices :: ([(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_map, key -> Maybe Vertex key_vertex, [(Vertex, Node key payload)] numbered_nodes) where max_v :: Vertex max_v = [Node key payload] -> 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) -- Keep the order intact to make the result depend on input order -- instead of key order 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 -- See Note [reduceNodesIntoVertices implementations] reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload reduceNodesIntoVerticesOrd :: 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 -- See Note [reduceNodesIntoVertices implementations] reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload reduceNodesIntoVerticesUniq :: ReduceFn key payload reduceNodesIntoVerticesUniq = ([(key, Vertex)] -> UniqFM Vertex) -> (key -> UniqFM Vertex -> Maybe Vertex) -> ReduceFn key payload forall key m payload. ([(key, Vertex)] -> m) -> (key -> m -> Maybe Vertex) -> ReduceFn key payload reduceNodesIntoVertices [(key, Vertex)] -> UniqFM Vertex forall key elt. Uniquable key => [(key, elt)] -> UniqFM elt listToUFM ((UniqFM Vertex -> key -> Maybe Vertex) -> key -> UniqFM Vertex -> Maybe Vertex forall a b c. (a -> b -> c) -> b -> a -> c flip UniqFM Vertex -> key -> Maybe Vertex forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt lookupUFM) {- ************************************************************************ * * * SCC * * ************************************************************************ -} 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 -- | 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 => [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 findCycle :: [Node key payload] -> Maybe [payload] findCycle [Node key payload] graph = 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 []) [] 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 ] -- 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 :: Node key payload root = (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 minWith (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 ]) DigraphNode payload root_payload key root_key [key] root_deps = Node key payload 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 -- Invariant: in a call (go visited ps qs), -- visited = union (map tail (ps ++ qs)) go :: Set key -> [WorkItem key payload] -> [WorkItem key payload] -> Maybe [payload] go Set key _ [] [] = Maybe [payload] forall a. Maybe a Nothing -- No cycles 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) 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 ] {- ************************************************************************ * * * Strongly Connected Component wrappers for Graph * * ************************************************************************ Note: the components are returned topologically sorted: later components depend on earlier ones, but not vice versa i.e. later components only have edges going from them to earlier ones. -} {- Note [Deterministic SCC] ~~~~~~~~~~~~~~~~~~~~~~~~ stronglyConnCompFromEdgedVerticesUniq, stronglyConnCompFromEdgedVerticesUniqR, stronglyConnCompFromEdgedVerticesOrd and stronglyConnCompFromEdgedVerticesOrdR provide a following guarantee: Given a deterministically ordered list of nodes it returns a deterministically ordered list of strongly connected components, where the list of vertices in an SCC is also deterministically ordered. Note that the order of edges doesn't need to be deterministic for this to work. We use the order of nodes to normalize the order of edges. -} stronglyConnCompG :: Graph node -> [SCC node] stronglyConnCompG :: Graph node -> [SCC node] stronglyConnCompG Graph node graph = Graph node -> Forest Vertex -> [SCC node] forall node. Graph node -> Forest Vertex -> [SCC node] decodeSccs Graph node graph Forest Vertex forest where forest :: Forest Vertex forest = {-# SCC "Digraph.scc" #-} IntGraph -> Forest Vertex scc (Graph node -> IntGraph forall node. Graph node -> IntGraph gr_int_graph Graph node graph) decodeSccs :: Graph node -> Forest Vertex -> [SCC node] decodeSccs :: Graph node -> Forest Vertex -> [SCC node] decodeSccs Graph { gr_int_graph :: forall node. Graph node -> IntGraph gr_int_graph = IntGraph graph, gr_vertex_to_node :: forall node. Graph node -> Vertex -> node gr_vertex_to_node = Vertex -> node vertex_fn } Forest Vertex forest = (Tree Vertex -> SCC node) -> Forest Vertex -> [SCC node] forall a b. (a -> b) -> [a] -> [b] map Tree Vertex -> SCC node decode Forest Vertex forest where decode :: Tree Vertex -> SCC node decode (Node Vertex v []) | Vertex -> Bool mentions_itself Vertex v = [node] -> SCC node forall vertex. [vertex] -> SCC vertex CyclicSCC [Vertex -> node vertex_fn Vertex v] | Bool otherwise = node -> SCC node forall vertex. vertex -> SCC vertex AcyclicSCC (Vertex -> node vertex_fn Vertex v) decode Tree Vertex other = [node] -> SCC node forall vertex. [vertex] -> SCC vertex CyclicSCC (Tree Vertex -> [node] -> [node] dec Tree Vertex other []) where dec :: Tree Vertex -> [node] -> [node] dec (Node Vertex v Forest Vertex ts) [node] vs = Vertex -> node vertex_fn Vertex v node -> [node] -> [node] forall a. a -> [a] -> [a] : (Tree Vertex -> [node] -> [node]) -> [node] -> Forest Vertex -> [node] forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr Tree Vertex -> [node] -> [node] dec [node] vs Forest Vertex ts mentions_itself :: Vertex -> Bool mentions_itself Vertex v = Vertex v Vertex -> [Vertex] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` (IntGraph graph IntGraph -> Vertex -> [Vertex] forall i e. Ix i => Array i e -> i -> e ! Vertex v) -- The following two versions are provided for backwards compatibility: -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] stronglyConnCompFromEdgedVerticesOrd :: Ord key => [Node key payload] -> [SCC payload] stronglyConnCompFromEdgedVerticesOrd :: [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 (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 -- The following two versions are provided for backwards compatibility: -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] stronglyConnCompFromEdgedVerticesUniq :: Uniquable key => [Node key payload] -> [SCC payload] stronglyConnCompFromEdgedVerticesUniq :: [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 (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 -- The "R" interface is used when you expect to apply SCC to -- (some of) the result of SCC, so you don't want to lose the dependency info -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] stronglyConnCompFromEdgedVerticesOrdR :: Ord key => [Node key payload] -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesOrdR :: [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 . 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 -- The "R" interface is used when you expect to apply SCC to -- (some of) the result of SCC, so you don't want to lose the dependency info -- See Note [Deterministic SCC] -- See Note [reduceNodesIntoVertices implementations] stronglyConnCompFromEdgedVerticesUniqR :: Uniquable key => [Node key payload] -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesUniqR :: [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 . 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 {- ************************************************************************ * * * Misc wrappers for Graph * * ************************************************************************ -} topologicalSortG :: Graph node -> [node] topologicalSortG :: 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] topSort (Graph node -> IntGraph forall node. Graph node -> IntGraph gr_int_graph Graph node graph) reachableG :: Graph node -> node -> [node] reachableG :: Graph node -> node -> [node] reachableG 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. HasCallStack => [Char] -> Maybe a -> a expectJust [Char] "reachableG" (Graph node -> node -> Maybe Vertex forall node. Graph node -> node -> Maybe Vertex gr_node_to_vertex Graph node graph node from) 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 from_vertex] -- | Given a list of roots return all reachable nodes. reachablesG :: Graph node -> [node] -> [node] reachablesG :: 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 :: 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 verticesG :: Graph node -> [node] verticesG :: Graph node -> [node] verticesG 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] -> [node]) -> [Vertex] -> [node] forall a b. (a -> b) -> a -> b $ IntGraph -> [Vertex] vertices (Graph node -> IntGraph forall node. Graph node -> IntGraph gr_int_graph Graph node graph) edgesG :: Graph node -> [Edge node] edgesG :: Graph node -> [Edge node] edgesG Graph node graph = ((Vertex, Vertex) -> Edge node) -> [(Vertex, Vertex)] -> [Edge node] forall a b. (a -> b) -> [a] -> [b] map (\(Vertex v1, Vertex v2) -> node -> node -> Edge node forall node. node -> node -> Edge node Edge (Vertex -> node v2n Vertex v1) (Vertex -> node v2n Vertex v2)) ([(Vertex, Vertex)] -> [Edge node]) -> [(Vertex, Vertex)] -> [Edge node] forall a b. (a -> b) -> a -> b $ IntGraph -> [(Vertex, Vertex)] edges (Graph node -> IntGraph forall node. Graph node -> IntGraph gr_int_graph Graph node graph) where v2n :: Vertex -> node v2n = Graph node -> Vertex -> node forall node. Graph node -> Vertex -> node gr_vertex_to_node Graph node graph transposeG :: Graph node -> Graph node transposeG :: 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 :: Graph node -> Bool emptyG Graph node g = IntGraph -> Bool graphEmpty (Graph node -> IntGraph forall node. Graph node -> IntGraph gr_int_graph Graph node g) {- ************************************************************************ * * * Showing Graphs * * ************************************************************************ -} instance Outputable node => Outputable (Graph node) where ppr :: Graph node -> SDoc ppr Graph node graph = [SDoc] -> SDoc vcat [ SDoc -> Vertex -> SDoc -> SDoc hang ([Char] -> SDoc text [Char] "Vertices:") Vertex 2 ([SDoc] -> SDoc vcat ((node -> SDoc) -> [node] -> [SDoc] forall a b. (a -> b) -> [a] -> [b] map node -> SDoc forall a. Outputable a => a -> SDoc ppr ([node] -> [SDoc]) -> [node] -> [SDoc] forall a b. (a -> b) -> a -> b $ Graph node -> [node] forall node. Graph node -> [node] verticesG Graph node graph)), SDoc -> Vertex -> SDoc -> SDoc hang ([Char] -> SDoc text [Char] "Edges:") Vertex 2 ([SDoc] -> SDoc vcat ((Edge node -> SDoc) -> [Edge node] -> [SDoc] forall a b. (a -> b) -> [a] -> [b] map Edge node -> SDoc forall a. Outputable a => a -> SDoc ppr ([Edge node] -> [SDoc]) -> [Edge node] -> [SDoc] forall a b. (a -> b) -> a -> b $ Graph node -> [Edge node] forall node. Graph node -> [Edge node] edgesG Graph node graph)) ] instance Outputable node => Outputable (Edge node) where ppr :: Edge node -> SDoc ppr (Edge node from node to) = node -> SDoc forall a. Outputable a => a -> SDoc ppr node from SDoc -> SDoc -> SDoc <+> [Char] -> SDoc text [Char] "->" SDoc -> SDoc -> SDoc <+> node -> SDoc forall a. Outputable a => a -> SDoc ppr node to 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 {- ************************************************************************ * * * IntGraphs * * ************************************************************************ -} type IntGraph = G.Graph {- ------------------------------------------------------------ -- Depth first search numbering ------------------------------------------------------------ -} -- Data.Tree has flatten for Tree, but nothing for Forest preorderF :: Forest a -> [a] preorderF :: Forest a -> [a] preorderF Forest a ts = [[a]] -> [a] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat ((Tree a -> [a]) -> Forest a -> [[a]] forall a b. (a -> b) -> [a] -> [b] map Tree a -> [a] forall a. Tree a -> [a] flatten Forest a ts) {- ------------------------------------------------------------ -- Finding reachable vertices ------------------------------------------------------------ -} -- This generalizes reachable which was found in Data.Graph reachable :: IntGraph -> [Vertex] -> [Vertex] reachable :: IntGraph -> [Vertex] -> [Vertex] reachable IntGraph g [Vertex] vs = Forest Vertex -> [Vertex] forall a. Forest a -> [a] preorderF (IntGraph -> [Vertex] -> Forest Vertex dfs IntGraph g [Vertex] vs) {- ************************************************************************ * * * Classify Edge Types * * ************************************************************************ -} -- Remark: While we could generalize this algorithm this comes at a runtime -- cost and with no advantages. If you find yourself using this with graphs -- not easily represented using Int nodes please consider rewriting this -- using the more general Graph type. -- | Edge direction based on DFS Classification data EdgeType = Forward | Cross | Backward -- ^ Loop back towards the root node. -- Eg backjumps in loops | SelfLoop -- ^ v -> v deriving (EdgeType -> EdgeType -> Bool (EdgeType -> EdgeType -> Bool) -> (EdgeType -> EdgeType -> Bool) -> Eq EdgeType forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: EdgeType -> EdgeType -> Bool $c/= :: EdgeType -> EdgeType -> Bool == :: EdgeType -> EdgeType -> Bool $c== :: 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 min :: EdgeType -> EdgeType -> EdgeType $cmin :: EdgeType -> EdgeType -> EdgeType max :: EdgeType -> EdgeType -> EdgeType $cmax :: EdgeType -> EdgeType -> EdgeType >= :: EdgeType -> EdgeType -> Bool $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 compare :: EdgeType -> EdgeType -> Ordering $ccompare :: EdgeType -> EdgeType -> Ordering $cp1Ord :: Eq EdgeType Ord) instance Outputable EdgeType where ppr :: EdgeType -> SDoc ppr EdgeType Forward = [Char] -> SDoc text [Char] "Forward" ppr EdgeType Cross = [Char] -> SDoc text [Char] "Cross" ppr EdgeType Backward = [Char] -> SDoc text [Char] "Backward" ppr EdgeType SelfLoop = [Char] -> SDoc 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 /= :: Time -> Time -> Bool $c/= :: Time -> Time -> Bool == :: Time -> Time -> Bool $c== :: 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 min :: Time -> Time -> Time $cmin :: Time -> Time -> Time max :: Time -> Time -> Time $cmax :: Time -> Time -> Time >= :: Time -> Time -> Bool $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 compare :: Time -> Time -> Ordering $ccompare :: Time -> Time -> Ordering $cp1Ord :: Eq 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 fromInteger :: Integer -> Time $cfromInteger :: Integer -> Time signum :: Time -> Time $csignum :: Time -> Time abs :: Time -> Time $cabs :: Time -> Time negate :: Time -> Time $cnegate :: Time -> Time * :: Time -> Time -> Time $c* :: Time -> Time -> Time - :: Time -> Time -> Time $c- :: Time -> Time -> Time + :: Time -> Time -> Time $c+ :: Time -> Time -> Time Num,Rational -> Time -> SDoc Time -> SDoc (Time -> SDoc) -> (Rational -> Time -> SDoc) -> Outputable Time forall a. (a -> SDoc) -> (Rational -> a -> SDoc) -> Outputable a pprPrec :: Rational -> Time -> SDoc $cpprPrec :: Rational -> Time -> SDoc ppr :: Time -> SDoc $cppr :: Time -> SDoc Outputable) --Allow for specialzation {-# INLINEABLE classifyEdges #-} -- | Given a start vertex, a way to get successors from a node -- and a list of (directed) edges classify the types of edges. classifyEdges :: forall key. Uniquable key => key -> (key -> [key]) -> [(key,key)] -> [((key, key), EdgeType)] classifyEdges :: key -> (key -> [key]) -> [(key, key)] -> [((key, key), EdgeType)] classifyEdges key root key -> [key] getSucc [(key, key)] edges = --let uqe (from,to) = (getUnique from, getUnique to) --in pprTrace "Edges:" (ppr $ map uqe 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 Time starts, UniqFM Time ends) = (Time, UniqFM Time, UniqFM Time) -> key -> (Time, UniqFM Time, UniqFM Time) addTimes (Time 0,UniqFM Time forall elt. UniqFM elt emptyUFM,UniqFM Time forall elt. UniqFM 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 p -> key -> p getTime UniqFM p event key node | Just p time <- UniqFM p -> key -> Maybe p forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt lookupUFM UniqFM p event key node = p time | Bool otherwise = [Char] -> SDoc -> p forall a. HasCallStack => [Char] -> SDoc -> a pprPanic [Char] "Failed to classify edge of CFG - not not timed" ([Char] -> SDoc text [Char] "edges" SDoc -> SDoc -> SDoc <> (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 <+> UniqFM Time -> SDoc forall a. Outputable a => a -> SDoc ppr UniqFM Time starts SDoc -> SDoc -> SDoc <+> UniqFM Time -> SDoc forall a. Outputable a => a -> SDoc ppr UniqFM Time ends ) startFrom :: Time startFrom = UniqFM Time -> key -> Time forall key p. Uniquable key => UniqFM p -> key -> p getTime UniqFM Time starts key from startTo :: Time startTo = UniqFM Time -> key -> Time forall key p. Uniquable key => UniqFM p -> key -> p getTime UniqFM Time starts key to endFrom :: Time endFrom = UniqFM Time -> key -> Time forall key p. Uniquable key => UniqFM p -> key -> p getTime UniqFM Time ends key from endTo :: Time endTo = UniqFM Time -> key -> Time forall key p. Uniquable key => UniqFM p -> key -> p getTime UniqFM Time ends key to addTimes :: (Time, UniqFM Time, UniqFM Time) -> key -> (Time, UniqFM Time, UniqFM Time) addTimes :: (Time, UniqFM Time, UniqFM Time) -> key -> (Time, UniqFM Time, UniqFM Time) addTimes (Time time,UniqFM Time starts,UniqFM Time ends) key n --Dont reenter nodes | key -> UniqFM Time -> Bool forall key elt. Uniquable key => key -> UniqFM elt -> Bool elemUFM key n UniqFM Time starts = (Time time,UniqFM Time starts,UniqFM Time ends) | Bool otherwise = let starts' :: UniqFM Time starts' = UniqFM Time -> key -> Time -> UniqFM Time forall key elt. Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt addToUFM UniqFM 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 Time starts'',UniqFM Time ends') = ((Time, UniqFM Time, UniqFM Time) -> key -> (Time, UniqFM Time, UniqFM Time)) -> (Time, UniqFM Time, UniqFM Time) -> [key] -> (Time, UniqFM Time, UniqFM Time) forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' (Time, UniqFM Time, UniqFM Time) -> key -> (Time, UniqFM Time, UniqFM Time) addTimes (Time time',UniqFM Time starts',UniqFM Time ends) [key] succs ends'' :: UniqFM Time ends'' = UniqFM Time -> key -> Time -> UniqFM Time forall key elt. Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt addToUFM UniqFM Time ends' key n Time time'' in (Time time'' Time -> Time -> Time forall a. Num a => a -> a -> a + Time 1, UniqFM Time starts'', UniqFM Time ends'')