-- (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 a :: b
a b :: a
b c :: [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 (1, 0) []) ([Char] -> Vertex -> a
forall a. HasCallStack => [Char] -> a
error "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 :: ReduceFn key payload
_reduceFn []            = Graph (Node key payload)
forall a. Graph a
emptyGraph
graphFromEdgedVertices reduceFn :: ReduceFn key payload
reduceFn edged_vertices :: [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
        (bounds :: (Vertex, Vertex)
bounds, vertex_fn :: Vertex -> Node key payload
vertex_fn, key_vertex :: key -> Maybe Vertex
key_vertex, numbered_nodes :: [(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)
                             | (v :: 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 fromList :: [(key, Vertex)] -> m
fromList lookup :: key -> m -> Maybe Vertex
lookup nodes :: [Node key payload]
nodes key_extractor :: 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
- 1
    bounds :: (Vertex, Vertex)
bounds          = (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 [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) | (v :: Vertex
v, node :: Node key payload
node) <- [(Vertex, Node key payload)]
numbered_nodes ]
    key_vertex :: key -> Maybe Vertex
key_vertex k :: 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 graph :: [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 root_payload :: payload
root_payload root_key :: key
root_key root_deps :: [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 _       [] [] = Maybe [payload]
forall a. Maybe a
Nothing  -- No cycles
    go visited :: Set key
visited [] qs :: [WorkItem key payload]
qs = Set key
-> [WorkItem key payload]
-> [WorkItem key payload]
-> Maybe [payload]
go Set key
visited [WorkItem key payload]
qs []
    go visited :: Set key
visited (((DigraphNode payload :: payload
payload key :: key
key deps :: [key]
deps), path :: [payload]
path) : ps :: [WorkItem key payload]
ps) qs :: [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 deps :: [key]
deps path :: [payload]
path = [ (Node key payload
n, [payload]
path) | Just n :: 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 :: 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 :: 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 v :: 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 other :: 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 v :: Vertex
v ts :: Forest Vertex
ts) vs :: [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 v :: 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 :: 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 :: Graph node
graph from :: 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 "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 :: Graph node
graph froms :: [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 v :: 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 :: Graph node
graph node :: 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 :: 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 :: Graph node
graph = ((Vertex, Vertex) -> Edge node)
-> [(Vertex, Vertex)] -> [Edge node]
forall a b. (a -> b) -> [a] -> [b]
map (\(v1 :: Vertex
v1, v2 :: 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 :: 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 g :: 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 :: Graph node
graph = [SDoc] -> SDoc
vcat [
                  SDoc -> Vertex -> SDoc -> SDoc
hang ([Char] -> SDoc
text "Vertices:") 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 "Edges:") 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 from :: node
from to :: node
to) = node -> SDoc
forall a. Outputable a => a -> SDoc
ppr node
from SDoc -> SDoc -> SDoc
<+> [Char] -> SDoc
text "->" SDoc -> SDoc -> SDoc
<+> node -> SDoc
forall a. Outputable a => a -> SDoc
ppr node
to

graphEmpty :: G.Graph -> Bool
graphEmpty :: IntGraph -> Bool
graphEmpty g :: IntGraph
g = Vertex
lo Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
> Vertex
hi
  where (lo :: Vertex
lo, hi :: 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 ts :: 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 g :: IntGraph
g vs :: [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 Forward = [Char] -> SDoc
text "Forward"
  ppr Cross = [Char] -> SDoc
text "Cross"
  ppr Backward = [Char] -> SDoc
text "Backward"
  ppr SelfLoop = [Char] -> SDoc
text "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 root :: key
root getSucc :: key -> [key]
getSucc edges :: [(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
_time, starts :: UniqFM Time
starts, ends :: UniqFM Time
ends) = (Time, UniqFM Time, UniqFM Time)
-> key -> (Time, UniqFM Time, UniqFM Time)
addTimes (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 (from :: key
from,to :: 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 "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 event :: UniqFM p
event node :: key
node
          | Just time :: 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 "Failed to classify edge of CFG - not not timed"
            ([Char] -> SDoc
text "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
time,starts :: UniqFM Time
starts,ends :: UniqFM Time
ends) n :: 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
+ 1
          succs :: [key]
succs = key -> [key]
getSucc key
n :: [key]
          (time'' :: Time
time'',starts'' :: UniqFM Time
starts'',ends' :: 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
+ 1, UniqFM Time
starts'', UniqFM Time
ends'')