-- (c) The University of Glasgow 2006


{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

module GHC.Data.Graph.Directed (
        Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
        graphFromVerticesAndAdjacency,

        SCC(..), Node(..), G.flattenSCC, G.flattenSCCs,
        stronglyConnCompG,
        topologicalSortG,
        verticesG, edgesG, hasVertexG,
        reachableG, reachablesG, transposeG, allReachable, allReachableCyclic, outgoingG,
        emptyG,

        findCycle,

        -- For backwards compatibility with the simpler version of Digraph
        stronglyConnCompFromEdgedVerticesOrd,
        stronglyConnCompFromEdgedVerticesOrdR,
        stronglyConnCompFromEdgedVerticesUniq,
        stronglyConnCompFromEdgedVerticesUniqR,

        -- Simple way to classify edges
        EdgeType(..), classifyEdges
        ) where

------------------------------------------------------------------------------
-- 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 GHC.Prelude

import GHC.Utils.Misc ( minWith, count )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.Maybe ( expectJust )

-- std interfaces
import Data.Maybe
import Data.Array
import Data.List ( sort )
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Data.Graph as G
import Data.Graph ( Vertex, Bounds, SCC(..) ) -- Used in the underlying representation
import Data.Tree
import GHC.Types.Unique
import GHC.Types.Unique.FM
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.Map as M
import qualified Data.Set as S

{-
************************************************************************
*                                                                      *
*      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 {
    forall node. Graph node -> IntGraph
gr_int_graph      :: IntGraph,
    forall node. Graph node -> Vertex -> node
gr_vertex_to_node :: Vertex -> node,
    forall 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 {
      forall key payload. Node key payload -> payload
node_payload :: payload, -- ^ User data
      forall key payload. Node key payload -> key
node_key :: key, -- ^ User defined node id
      forall key payload. 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) = forall a. Outputable a => a -> SDoc
ppr (b
a, a
b, [a]
c)

emptyGraph :: Graph a
emptyGraph :: forall a. Graph a
emptyGraph = forall node.
IntGraph
-> (Vertex -> node) -> (node -> Maybe Vertex) -> Graph node
Graph (forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Vertex
1, Vertex
0) []) (forall a. HasCallStack => [Char] -> a
error [Char]
"emptyGraph") (forall a b. a -> b -> a
const 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 :: forall key payload.
ReduceFn key payload
-> [Node key payload] -> Graph (Node key payload)
graphFromEdgedVertices ReduceFn key payload
_reduceFn []            = forall a. Graph a
emptyGraph
graphFromEdgedVertices ReduceFn key payload
reduceFn [Node key payload]
edged_vertices =
  forall node.
IntGraph
-> (Vertex -> node) -> (node -> Maybe Vertex) -> Graph node
Graph IntGraph
graph Vertex -> Node key payload
vertex_fn (key -> Maybe Vertex
key_vertex forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key payload. Node key payload -> key
key_extractor)
  where key_extractor :: Node key payload -> key
key_extractor = forall key payload. Node key payload -> key
node_key
        (Bounds
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 forall key payload. Node key payload -> key
key_extractor
        graph :: IntGraph
graph = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array Bounds
bounds [ (Vertex
v, forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe key -> Maybe Vertex
key_vertex [key]
ks)
                             | (Vertex
v, (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 :: forall key payload.
Ord key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesOrd = forall key payload.
ReduceFn key payload
-> [Node key payload] -> Graph (Node key payload)
graphFromEdgedVertices 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 :: forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq = forall key payload.
ReduceFn key payload
-> [Node key payload] -> Graph (Node key payload)
graphFromEdgedVertices 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 accommodate 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 :: forall key m payload.
([(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 =
  (Bounds
bounds, forall i e. Ix i => Array i e -> i -> e
(!) Array Vertex (Node key payload)
vertex_map, key -> Maybe Vertex
key_vertex, [(Vertex, Node key payload)]
numbered_nodes)
  where
    max_v :: Vertex
max_v           = forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [Node key payload]
nodes forall a. Num a => a -> a -> a
- Vertex
1
    bounds :: Bounds
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  = forall a b. [a] -> [b] -> [(a, b)]
zip [Vertex
0..] [Node key payload]
nodes
    vertex_map :: Array Vertex (Node key payload)
vertex_map      = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array Bounds
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 :: forall key payload. Ord key => ReduceFn key payload
reduceNodesIntoVerticesOrd = forall key m payload.
([(key, Vertex)] -> m)
-> (key -> m -> Maybe Vertex) -> ReduceFn key payload
reduceNodesIntoVertices forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup

-- See Note [reduceNodesIntoVertices implementations]
reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload
reduceNodesIntoVerticesUniq :: forall key payload. Uniquable key => ReduceFn key payload
reduceNodesIntoVerticesUniq = forall key m payload.
([(key, Vertex)] -> m)
-> (key -> m -> Maybe Vertex) -> ReduceFn key payload
reduceNodesIntoVertices forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall key elt. Uniquable key => UniqFM key 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 :: forall payload key.
Ord key =>
[Node key payload] -> Maybe [payload]
findCycle [Node key payload]
graph
  = Set key
-> [WorkItem key payload]
-> [WorkItem key payload]
-> Maybe [payload]
go 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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (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 = forall a b. (a, b) -> a
fst (forall b a. Ord b => (a -> b) -> [a] -> a
minWith forall a b. (a, b) -> b
snd [ (Node key payload
node, forall a. (a -> Bool) -> [a] -> Vertex
count (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map key (Node key payload)
env)
                                           (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
_       [] [] = 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 forall a. Eq a => a -> a -> Bool
== key
root_key           = forall a. a -> Maybe a
Just (payload
root_payload forall a. a -> [a] -> [a]
: forall a. [a] -> [a]
reverse [payload]
path)
       | key
key 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 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 (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 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 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 <- forall a b. (a -> b) -> [a] -> [b]
map (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 :: forall node. Graph node -> [SCC node]
stronglyConnCompG Graph node
graph = forall node. Graph node -> [SCC Vertex] -> [SCC node]
decodeSccs Graph node
graph forall a b. (a -> b) -> a -> b
$ IntGraph -> [SCC Vertex]
scc (forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)

decodeSccs :: Graph node -> [SCC Vertex] -> [SCC node]
decodeSccs :: forall node. Graph node -> [SCC Vertex] -> [SCC node]
decodeSccs Graph { gr_vertex_to_node :: forall node. Graph node -> Vertex -> node
gr_vertex_to_node = Vertex -> node
vertex_fn }
  = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vertex -> node
vertex_fn)

-- 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 :: forall key payload. Ord key => [Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd
  = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall key payload. Node key payload -> payload
node_payload) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq
  = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall key payload. Node key payload -> payload
node_payload) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall key payload.
Ord key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesOrdR =
  forall node. Graph node -> [SCC node]
stronglyConnCompG forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key payload.
Ord key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesOrd

-- 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 :: forall key payload.
Uniquable key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR =
  forall node. Graph node -> [SCC node]
stronglyConnCompG forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq

{-
************************************************************************
*                                                                      *
*      Misc wrappers for Graph
*                                                                      *
************************************************************************
-}

topologicalSortG :: Graph node -> [node]
topologicalSortG :: forall node. Graph node -> [node]
topologicalSortG Graph node
graph = forall a b. (a -> b) -> [a] -> [b]
map (forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph) [Vertex]
result
  where result :: [Vertex]
result = {-# SCC "Digraph.topSort" #-} IntGraph -> [Vertex]
G.topSort (forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)

reachableG :: Graph node -> node -> [node]
reachableG :: forall node. Graph node -> node -> [node]
reachableG Graph node
graph node
from = forall a b. (a -> b) -> [a] -> [b]
map (forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph) [Vertex]
result
  where from_vertex :: Vertex
from_vertex = forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"reachableG" (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 (forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph) [Vertex
from_vertex]

outgoingG :: Graph node -> node -> [node]
outgoingG :: forall node. Graph node -> node -> [node]
outgoingG Graph node
graph node
from = forall a b. (a -> b) -> [a] -> [b]
map (forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph) [Vertex]
result
  where from_vertex :: Vertex
from_vertex = forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"reachableG" (forall node. Graph node -> node -> Maybe Vertex
gr_node_to_vertex Graph node
graph node
from)
        result :: [Vertex]
result = forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph forall i e. Ix i => Array i e -> i -> e
! Vertex
from_vertex

-- | Given a list of roots return all reachable nodes.
reachablesG :: Graph node -> [node] -> [node]
reachablesG :: forall node. Graph node -> [node] -> [node]
reachablesG Graph node
graph [node]
froms = forall a b. (a -> b) -> [a] -> [b]
map (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 (forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph) [Vertex]
vs
        vs :: [Vertex]
vs = [ Vertex
v | Just Vertex
v <- forall a b. (a -> b) -> [a] -> [b]
map (forall node. Graph node -> node -> Maybe Vertex
gr_node_to_vertex Graph node
graph) [node]
froms ]

-- | Efficiently construct a map which maps each key to it's set of transitive
-- dependencies. Only works on acyclic input.
allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key)
allReachable :: forall key node.
Ord key =>
Graph node -> (node -> key) -> Map key (Set key)
allReachable = forall key node.
Ord key =>
(IntGraph -> IntMap IntSet)
-> Graph node -> (node -> key) -> Map key (Set key)
all_reachable IntGraph -> IntMap IntSet
reachableGraph

-- | Efficiently construct a map which maps each key to it's set of transitive
-- dependencies. Less efficient than @allReachable@, but works on cyclic input as well.
allReachableCyclic :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key)
allReachableCyclic :: forall key node.
Ord key =>
Graph node -> (node -> key) -> Map key (Set key)
allReachableCyclic = forall key node.
Ord key =>
(IntGraph -> IntMap IntSet)
-> Graph node -> (node -> key) -> Map key (Set key)
all_reachable IntGraph -> IntMap IntSet
reachableGraphCyclic

all_reachable :: Ord key => (IntGraph -> IM.IntMap IS.IntSet) -> Graph node -> (node -> key) -> M.Map key (S.Set key)
all_reachable :: forall key node.
Ord key =>
(IntGraph -> IntMap IntSet)
-> Graph node -> (node -> key) -> Map key (Set key)
all_reachable IntGraph -> IntMap IntSet
int_reachables (Graph IntGraph
g Vertex -> node
from node -> Maybe Vertex
_) node -> key
keyOf =
  forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(key
k, forall b. (Vertex -> b -> b) -> b -> IntSet -> b
IS.foldr (\Vertex
v' Set key
vs -> node -> key
keyOf (Vertex -> node
from Vertex
v') forall a. Ord a => a -> Set a -> Set a
`S.insert` Set key
vs) forall a. Set a
S.empty IntSet
vs)
             | (Vertex
v, IntSet
vs) <- forall a. IntMap a -> [(Vertex, a)]
IM.toList IntMap IntSet
int_graph
             , let k :: key
k = node -> key
keyOf (Vertex -> node
from Vertex
v)]
  where
    int_graph :: IntMap IntSet
int_graph = IntGraph -> IntMap IntSet
int_reachables IntGraph
g

hasVertexG :: Graph node -> node -> Bool
hasVertexG :: forall node. Graph node -> node -> Bool
hasVertexG Graph node
graph node
node = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall node. Graph node -> node -> Maybe Vertex
gr_node_to_vertex Graph node
graph node
node

verticesG :: Graph node -> [node]
verticesG :: forall node. Graph node -> [node]
verticesG Graph node
graph = forall a b. (a -> b) -> [a] -> [b]
map (forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph) forall a b. (a -> b) -> a -> b
$ IntGraph -> [Vertex]
G.vertices (forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)

edgesG :: Graph node -> [Edge node]
edgesG :: forall node. Graph node -> [Edge node]
edgesG Graph node
graph = forall a b. (a -> b) -> [a] -> [b]
map (\(Vertex
v1, Vertex
v2) -> forall node. node -> node -> Edge node
Edge (Vertex -> node
v2n Vertex
v1) (Vertex -> node
v2n Vertex
v2)) forall a b. (a -> b) -> a -> b
$ IntGraph -> [Bounds]
G.edges (forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph)
  where v2n :: Vertex -> node
v2n = forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph

transposeG :: Graph node -> Graph node
transposeG :: forall node. Graph node -> Graph node
transposeG Graph node
graph = forall node.
IntGraph
-> (Vertex -> node) -> (node -> Maybe Vertex) -> Graph node
Graph (IntGraph -> IntGraph
G.transposeG (forall node. Graph node -> IntGraph
gr_int_graph Graph node
graph))
                         (forall node. Graph node -> Vertex -> node
gr_vertex_to_node Graph node
graph)
                         (forall node. Graph node -> node -> Maybe Vertex
gr_node_to_vertex Graph node
graph)

emptyG :: Graph node -> Bool
emptyG :: forall node. Graph node -> Bool
emptyG Graph node
g = IntGraph -> Bool
graphEmpty (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 = forall doc. IsDoc doc => [doc] -> doc
vcat [
                  SDoc -> Vertex -> SDoc -> SDoc
hang (forall doc. IsLine doc => [Char] -> doc
text [Char]
"Vertices:") Vertex
2 (forall doc. IsDoc doc => [doc] -> doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall node. Graph node -> [node]
verticesG Graph node
graph)),
                  SDoc -> Vertex -> SDoc -> SDoc
hang (forall doc. IsLine doc => [Char] -> doc
text [Char]
"Edges:") Vertex
2 (forall doc. IsDoc doc => [doc] -> doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ 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) = forall a. Outputable a => a -> SDoc
ppr node
from forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr node
to

graphEmpty :: G.Graph -> Bool
graphEmpty :: IntGraph -> Bool
graphEmpty IntGraph
g = Vertex
lo forall a. Ord a => a -> a -> Bool
> Vertex
hi
  where (Vertex
lo, Vertex
hi) = 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 :: forall a. Forest a -> [a]
preorderF Forest a
ts         = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 = forall a. Forest a -> [a]
preorderF (IntGraph -> [Vertex] -> Forest Vertex
G.dfs IntGraph
g [Vertex]
vs)

reachableGraph :: IntGraph -> IM.IntMap IS.IntSet
reachableGraph :: IntGraph -> IntMap IntSet
reachableGraph IntGraph
g = IntMap IntSet
res
  where
    do_one :: Vertex -> IntSet
do_one Vertex
v = forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions ([Vertex] -> IntSet
IS.fromList (IntGraph
g forall i e. Ix i => Array i e -> i -> e
! Vertex
v) forall a. a -> [a] -> [a]
: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Vertex -> IntMap a -> Maybe a
IM.lookup IntMap IntSet
res) (IntGraph
g forall i e. Ix i => Array i e -> i -> e
! Vertex
v))
    res :: IntMap IntSet
res = forall a. [(Vertex, a)] -> IntMap a
IM.fromList [(Vertex
v, Vertex -> IntSet
do_one Vertex
v) | Vertex
v <- IntGraph -> [Vertex]
G.vertices IntGraph
g]

scc :: IntGraph -> [SCC Vertex]
scc :: IntGraph -> [SCC Vertex]
scc IntGraph
graph = forall a b. (a -> b) -> [a] -> [b]
map Tree Vertex -> SCC Vertex
decode Forest Vertex
forest
  where
    forest :: Forest Vertex
forest = {-# SCC "Digraph.scc" #-} IntGraph -> Forest Vertex
G.scc IntGraph
graph

    decode :: Tree Vertex -> SCC Vertex
decode (Node Vertex
v []) | Vertex -> Bool
mentions_itself Vertex
v = forall vertex. [vertex] -> SCC vertex
CyclicSCC [Vertex
v]
                       | Bool
otherwise         = forall vertex. vertex -> SCC vertex
AcyclicSCC Vertex
v
    decode Tree Vertex
other = forall vertex. [vertex] -> SCC vertex
CyclicSCC (forall {a}. Tree a -> [a] -> [a]
dec Tree Vertex
other [])
      where dec :: Tree a -> [a] -> [a]
dec (Node a
v [Tree a]
ts) [a]
vs = a
v forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tree a -> [a] -> [a]
dec [a]
vs [Tree a]
ts
    mentions_itself :: Vertex -> Bool
mentions_itself Vertex
v = Vertex
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (IntGraph
graph forall i e. Ix i => Array i e -> i -> e
! Vertex
v)

reachableGraphCyclic :: IntGraph -> IM.IntMap IS.IntSet
reachableGraphCyclic :: IntGraph -> IntMap IntSet
reachableGraphCyclic IntGraph
g = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntMap IntSet -> SCC Vertex -> IntMap IntSet
add_one_comp forall a. Monoid a => a
mempty [SCC Vertex]
comps
  where
    neighboursOf :: Vertex -> [Vertex]
neighboursOf Vertex
v = IntGraph
gforall i e. Ix i => Array i e -> i -> e
!Vertex
v

    comps :: [SCC Vertex]
comps = IntGraph -> [SCC Vertex]
scc IntGraph
g

    -- To avoid divergence on cyclic input, we build the result
    -- strongly connected component by component, in topological
    -- order. For each SCC, we know that:
    --
    --   * All vertices in the component can reach all other vertices
    --     in the component ("local" reachables)
    --
    --   * Other reachable vertices ("remote" reachables) must come
    --     from earlier components, either via direct neighbourhood, or
    --     transitively from earlier reachability map
    --
    -- This allows us to build the extension of the reachability map
    -- directly, without any self-reference, thereby avoiding a loop.
    add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet
    add_one_comp :: IntMap IntSet -> SCC Vertex -> IntMap IntSet
add_one_comp IntMap IntSet
earlier (AcyclicSCC Vertex
v) = forall a. Vertex -> a -> IntMap a -> IntMap a
IM.insert Vertex
v IntSet
all_remotes IntMap IntSet
earlier
      where
        earlier_neighbours :: [Vertex]
earlier_neighbours = Vertex -> [Vertex]
neighboursOf Vertex
v
        earlier_further :: [IntSet]
earlier_further = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Vertex -> IntMap a -> Maybe a
IM.lookup IntMap IntSet
earlier) [Vertex]
earlier_neighbours
        all_remotes :: IntSet
all_remotes = forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions ([Vertex] -> IntSet
IS.fromList [Vertex]
earlier_neighbours forall a. a -> [a] -> [a]
: [IntSet]
earlier_further)
    add_one_comp IntMap IntSet
earlier (CyclicSCC [Vertex]
vs) = forall a. IntMap a -> IntMap a -> IntMap a
IM.union (forall a. [(Vertex, a)] -> IntMap a
IM.fromList [(Vertex
v, Vertex -> IntSet
local Vertex
v IntSet -> IntSet -> IntSet
`IS.union` IntSet
all_remotes) | Vertex
v <- [Vertex]
vs]) IntMap IntSet
earlier
      where
        all_locals :: IntSet
all_locals = [Vertex] -> IntSet
IS.fromList [Vertex]
vs
        local :: Vertex -> IntSet
local Vertex
v = Vertex -> IntSet -> IntSet
IS.delete Vertex
v IntSet
all_locals
            -- Arguably, for a cyclic SCC we should include each
            -- vertex in its own reachable set. However, this could
            -- lead to a lot of extra pain in client code to avoid
            -- looping when traversing the reachability map.
        all_neighbours :: IntSet
all_neighbours = [Vertex] -> IntSet
IS.fromList (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Vertex -> [Vertex]
neighboursOf [Vertex]
vs)
        earlier_neighbours :: IntSet
earlier_neighbours = IntSet
all_neighbours IntSet -> IntSet -> IntSet
IS.\\ IntSet
all_locals
        earlier_further :: [IntSet]
earlier_further = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Vertex -> IntMap a -> Maybe a
IM.lookup IntMap IntSet
earlier) (IntSet -> [Vertex]
IS.toList IntSet
earlier_neighbours)
        all_remotes :: IntSet
all_remotes = forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions (IntSet
earlier_neighbours forall a. a -> [a] -> [a]
: [IntSet]
earlier_further)

{-
************************************************************************
*                                                                      *
*                         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
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
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
Ord)

instance Outputable EdgeType where
  ppr :: EdgeType -> SDoc
ppr EdgeType
Forward = forall doc. IsLine doc => [Char] -> doc
text [Char]
"Forward"
  ppr EdgeType
Cross = forall doc. IsLine doc => [Char] -> doc
text [Char]
"Cross"
  ppr EdgeType
Backward = forall doc. IsLine doc => [Char] -> doc
text [Char]
"Backward"
  ppr EdgeType
SelfLoop = forall doc. IsLine doc => [Char] -> doc
text [Char]
"SelfLoop"

newtype Time = Time Int deriving (Time -> Time -> Bool
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
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
Ord,Integer -> Time
Time -> Time
Time -> Time -> 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,Time -> SDoc
forall a. (a -> SDoc) -> Outputable a
ppr :: Time -> SDoc
$cppr :: Time -> SDoc
Outputable)

--Allow for specialization
{-# 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 :: forall key.
Uniquable key =>
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) $
    forall a b. [a] -> [b] -> [(a, b)]
zip [(key, key)]
edges forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (key, key) -> EdgeType
classify [(key, key)]
edges
  where
    (Time
_time, UniqFM key Time
starts, UniqFM key Time
ends) = (Time, UniqFM key Time, UniqFM key Time)
-> key -> (Time, UniqFM key Time, UniqFM key Time)
addTimes (Time
0,forall key elt. UniqFM key elt
emptyUFM,forall key elt. UniqFM key elt
emptyUFM) key
root
    classify :: (key,key) -> EdgeType
    classify :: (key, key) -> EdgeType
classify (key
from,key
to)
      | Time
startFrom forall a. Ord a => a -> a -> Bool
< Time
startTo
      , Time
endFrom   forall a. Ord a => a -> a -> Bool
> Time
endTo
      = EdgeType
Forward
      | Time
startFrom forall a. Ord a => a -> a -> Bool
> Time
startTo
      , Time
endFrom   forall a. Ord a => a -> a -> Bool
< Time
endTo
      = EdgeType
Backward
      | Time
startFrom forall a. Ord a => a -> a -> Bool
> Time
startTo
      , Time
endFrom   forall a. Ord a => a -> a -> Bool
> Time
endTo
      = EdgeType
Cross
      | forall a. Uniquable a => a -> Unique
getUnique key
from forall a. Eq a => a -> a -> Bool
== forall a. Uniquable a => a -> Unique
getUnique key
to
      = EdgeType
SelfLoop
      | Bool
otherwise
      = forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Failed to classify edge of Graph"
                 (forall a. Outputable a => a -> SDoc
ppr (forall a. Uniquable a => a -> Unique
getUnique key
from, forall a. Uniquable a => a -> Unique
getUnique key
to))

      where
        getTime :: UniqFM key Time -> key -> Time
getTime UniqFM key Time
event key
node
          | Just Time
time <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM key Time
event key
node
          = Time
time
          | Bool
otherwise
          = forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Failed to classify edge of CFG - not not timed"
            (forall doc. IsLine doc => [Char] -> doc
text [Char]
"edges" forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr (forall a. Uniquable a => a -> Unique
getUnique key
from, forall a. Uniquable a => a -> Unique
getUnique key
to)
                          forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr UniqFM key Time
starts forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr UniqFM key Time
ends )
        startFrom :: Time
startFrom = UniqFM key Time -> key -> Time
getTime UniqFM key Time
starts key
from
        startTo :: Time
startTo   = UniqFM key Time -> key -> Time
getTime UniqFM key Time
starts key
to
        endFrom :: Time
endFrom   = UniqFM key Time -> key -> Time
getTime UniqFM key Time
ends   key
from
        endTo :: Time
endTo     = UniqFM key Time -> key -> Time
getTime UniqFM key Time
ends   key
to

    addTimes :: (Time, UniqFM key Time, UniqFM key Time) -> key
             -> (Time, UniqFM key Time, UniqFM key Time)
    addTimes :: (Time, UniqFM key Time, UniqFM key Time)
-> key -> (Time, UniqFM key Time, UniqFM key Time)
addTimes (Time
time,UniqFM key Time
starts,UniqFM key Time
ends) key
n
      --Dont reenter nodes
      | forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
elemUFM key
n UniqFM key Time
starts
      = (Time
time,UniqFM key Time
starts,UniqFM key Time
ends)
      | Bool
otherwise =
        let
          starts' :: UniqFM key Time
starts' = forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM key Time
starts key
n 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 key Time
starts'',UniqFM key Time
ends') = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Time, UniqFM key Time, UniqFM key Time)
-> key -> (Time, UniqFM key Time, UniqFM key Time)
addTimes (Time
time',UniqFM key Time
starts',UniqFM key Time
ends) [key]
succs
          ends'' :: UniqFM key Time
ends'' = forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM key Time
ends' key
n Time
time''
        in
        (Time
time'' forall a. Num a => a -> a -> a
+ Time
1, UniqFM key Time
starts'', UniqFM key Time
ends'')

graphFromVerticesAndAdjacency
        :: Ord key
        => [Node key payload]
        -> [(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
                         -- do the same thing for the other one for backcompat reasons.
        -> Graph (Node key payload)
graphFromVerticesAndAdjacency :: forall key payload.
Ord key =>
[Node key payload] -> [(key, key)] -> Graph (Node key payload)
graphFromVerticesAndAdjacency []       [(key, key)]
_     = forall a. Graph a
emptyGraph
graphFromVerticesAndAdjacency [Node key payload]
vertices [(key, key)]
edges = forall node.
IntGraph
-> (Vertex -> node) -> (node -> Maybe Vertex) -> Graph node
Graph IntGraph
graph Vertex -> Node key payload
vertex_node (key -> Maybe Vertex
key_vertex forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key payload. Node key payload -> key
key_extractor)
  where key_extractor :: Node key payload -> key
key_extractor = forall key payload. Node key payload -> key
node_key
        (Bounds
bounds, Vertex -> Node key payload
vertex_node, key -> Maybe Vertex
key_vertex, [(Vertex, Node key payload)]
_) = forall key payload. Ord key => ReduceFn key payload
reduceNodesIntoVerticesOrd [Node key payload]
vertices forall key payload. Node key payload -> key
key_extractor
        key_vertex_pair :: (key, key) -> Bounds
key_vertex_pair (key
a, key
b) = (forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"graphFromVerticesAndAdjacency" forall a b. (a -> b) -> a -> b
$ key -> Maybe Vertex
key_vertex key
a,
                                  forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"graphFromVerticesAndAdjacency" forall a b. (a -> b) -> a -> b
$ key -> Maybe Vertex
key_vertex key
b)
        reduced_edges :: [Bounds]
reduced_edges = forall a b. (a -> b) -> [a] -> [b]
map (key, key) -> Bounds
key_vertex_pair [(key, key)]
edges
        graph :: IntGraph
graph = Bounds -> [Bounds] -> IntGraph
G.buildG Bounds
bounds [Bounds]
reduced_edges