    -- (c) The University of Glasgow 2006

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

    module GHC.Data.Graph.Directed (
            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 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 hiding (Graph, Edge, transposeG, reachable)
    import Data.Tree
    import GHC.Types.Unique
    import GHC.Types.Unique.FM

    {-
    ************************************************************************
    *                                                                      *
    *      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 -> Forest Vertex -> [SCC node]
    decodeSccs Graph node
    graph Forest Vertex
    forest
      where forest :: Forest Vertex
    forest = {-# SCC "Digraph.scc" #-} IntGraph -> Forest Vertex
    scc (forall node. Graph node -> IntGraph
    gr_int_graph Graph node
    graph)

    decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
    decodeSccs :: forall node. 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
      = 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 = forall vertex. [vertex] -> SCC vertex
    CyclicSCC [Vertex -> node
    vertex_fn Vertex
    v]
                           | Bool
    otherwise         = forall vertex. vertex -> SCC vertex
    AcyclicSCC (Vertex -> node
    vertex_fn Vertex
    v)
        decode Tree Vertex
    other = 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 forall a. a -> [a] -> [a]
    : 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 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)

    -- 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.
    ReduceFn key payload
    -> [Node key payload] -> Graph (Node key payload)
    graphFromEdgedVertices 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 :: 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.
    ReduceFn key payload
    -> [Node key payload] -> Graph (Node key payload)
    graphFromEdgedVertices forall key payload. Uniquable key => ReduceFn key payload
    reduceNodesIntoVerticesUniq

    {-
    ************************************************************************
    *                                                                      *
    *      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]
    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]

    -- | 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 ]

    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]
    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]
    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 = [SDoc] -> SDoc
    vcat [
                      SDoc -> Vertex -> SDoc -> SDoc
    hang ([Char] -> SDoc
    text [Char]
    "Vertices:") Vertex
    2 ([SDoc] -> SDoc
    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 ([Char] -> SDoc
    text [Char]
    "Edges:") Vertex
    2 ([SDoc] -> SDoc
    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 SDoc -> SDoc -> SDoc
    <+> [Char] -> SDoc
    text [Char]
    "->" SDoc -> SDoc -> SDoc
    <+> 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
    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
    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 = [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
    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"
                ([Char] -> SDoc
    text [Char]
    "edges" SDoc -> SDoc -> SDoc
    <> 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)
                              SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr UniqFM key Time
    starts SDoc -> SDoc -> SDoc
    <+> 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'')