{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module GHC.Data.Graph.Collapse
  ( PureSupernode(..)
  , Supernode(..)
  , collapseInductiveGraph
  , VizCollapseMonad(..)
  , NullCollapseViz(..)
  , runNullCollapse
  , MonadUniqSM(..)
  )
where

import GHC.Prelude

import Control.Exception
import Control.Monad
import Data.List (delete, union, insert, intersect)
import Data.Semigroup

import GHC.Cmm.Dataflow.Label
import GHC.Data.Graph.Inductive.Graph
import GHC.Types.Unique.Supply
import GHC.Utils.Panic


{-|
Module      : GHC.Data.Graph.Collapse
Description : Implement the "collapsing" algorithm Hecht and Ullman

A control-flow graph is reducible if and only if it is collapsible
according to the definition of Hecht and Ullman (1972).   This module
implements the collapsing algorithm of Hecht and Ullman, and if it
encounters a graph that is not collapsible, it splits nodes until the
graph is fully collapsed.  It then reports what nodes (if any) had to
be split in order to collapse the graph.  The information is used
upstream to node-split Cmm graphs.

The module uses the inductive graph representation cloned from the
Functional Graph Library (Hackage package `fgl`, modules
`GHC.Data.Graph.Inductive.*`.)

-}

-- Full reference to paper: Matthew S. Hecht and Jeffrey D. Ullman
-- (1972).  Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202.
-- https://doi.org/10.1137/0201014


------------------ Graph-splitting monad -----------------------

-- | If you want to visualize the graph-collapsing algorithm, create
-- an instance of monad `VizCollapseMonad`.  Each step in the
-- algorithm is announced to the monad as a side effect.  If you don't
-- care about visualization, you would use the `NullCollapseViz`
-- monad, in which these operations are no-ops.

class (Monad m) => MonadUniqSM m where
  liftUniqSM :: UniqSM a -> m a

class (MonadUniqSM m, Graph gr, Supernode s m) => VizCollapseMonad m gr s where
  consumeByInGraph :: Node -> Node -> gr s () -> m ()
  splitGraphAt :: gr s () -> LNode s -> m ()
  finalGraph :: gr s () -> m ()



-- | The identity monad as a `VizCollapseMonad`.  Use this monad when
-- you want efficiency in graph collapse.
newtype NullCollapseViz a = NullCollapseViz { forall a. NullCollapseViz a -> UniqSM a
unNCV :: UniqSM a }
  deriving ((forall a b. (a -> b) -> NullCollapseViz a -> NullCollapseViz b)
-> (forall a b. a -> NullCollapseViz b -> NullCollapseViz a)
-> Functor NullCollapseViz
forall a b. a -> NullCollapseViz b -> NullCollapseViz a
forall a b. (a -> b) -> NullCollapseViz a -> NullCollapseViz b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> NullCollapseViz a -> NullCollapseViz b
fmap :: forall a b. (a -> b) -> NullCollapseViz a -> NullCollapseViz b
$c<$ :: forall a b. a -> NullCollapseViz b -> NullCollapseViz a
<$ :: forall a b. a -> NullCollapseViz b -> NullCollapseViz a
Functor, Functor NullCollapseViz
Functor NullCollapseViz =>
(forall a. a -> NullCollapseViz a)
-> (forall a b.
    NullCollapseViz (a -> b) -> NullCollapseViz a -> NullCollapseViz b)
-> (forall a b c.
    (a -> b -> c)
    -> NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz c)
-> (forall a b.
    NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b)
-> (forall a b.
    NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz a)
-> Applicative NullCollapseViz
forall a. a -> NullCollapseViz a
forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz a
forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
forall a b.
NullCollapseViz (a -> b) -> NullCollapseViz a -> NullCollapseViz b
forall a b c.
(a -> b -> c)
-> NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> NullCollapseViz a
pure :: forall a. a -> NullCollapseViz a
$c<*> :: forall a b.
NullCollapseViz (a -> b) -> NullCollapseViz a -> NullCollapseViz b
<*> :: forall a b.
NullCollapseViz (a -> b) -> NullCollapseViz a -> NullCollapseViz b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz c
liftA2 :: forall a b c.
(a -> b -> c)
-> NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz c
$c*> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
*> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
$c<* :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz a
<* :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz a
Applicative, Applicative NullCollapseViz
Applicative NullCollapseViz =>
(forall a b.
 NullCollapseViz a -> (a -> NullCollapseViz b) -> NullCollapseViz b)
-> (forall a b.
    NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b)
-> (forall a. a -> NullCollapseViz a)
-> Monad NullCollapseViz
forall a. a -> NullCollapseViz a
forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
forall a b.
NullCollapseViz a -> (a -> NullCollapseViz b) -> NullCollapseViz b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
NullCollapseViz a -> (a -> NullCollapseViz b) -> NullCollapseViz b
>>= :: forall a b.
NullCollapseViz a -> (a -> NullCollapseViz b) -> NullCollapseViz b
$c>> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
>> :: forall a b.
NullCollapseViz a -> NullCollapseViz b -> NullCollapseViz b
$creturn :: forall a. a -> NullCollapseViz a
return :: forall a. a -> NullCollapseViz a
Monad, Monad NullCollapseViz
NullCollapseViz [Unique]
NullCollapseViz Unique
NullCollapseViz UniqSupply
Monad NullCollapseViz =>
NullCollapseViz UniqSupply
-> NullCollapseViz Unique
-> NullCollapseViz [Unique]
-> MonadUnique NullCollapseViz
forall (m :: * -> *).
Monad m =>
m UniqSupply -> m Unique -> m [Unique] -> MonadUnique m
$cgetUniqueSupplyM :: NullCollapseViz UniqSupply
getUniqueSupplyM :: NullCollapseViz UniqSupply
$cgetUniqueM :: NullCollapseViz Unique
getUniqueM :: NullCollapseViz Unique
$cgetUniquesM :: NullCollapseViz [Unique]
getUniquesM :: NullCollapseViz [Unique]
MonadUnique)

instance MonadUniqSM NullCollapseViz where
  liftUniqSM :: forall a. UniqSM a -> NullCollapseViz a
liftUniqSM = UniqSM a -> NullCollapseViz a
forall a. UniqSM a -> NullCollapseViz a
NullCollapseViz

instance (Graph gr, Supernode s NullCollapseViz) =>
    VizCollapseMonad NullCollapseViz gr s where
  consumeByInGraph :: Node -> Node -> gr s () -> NullCollapseViz ()
consumeByInGraph Node
_ Node
_ gr s ()
_ = () -> NullCollapseViz ()
forall a. a -> NullCollapseViz a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  splitGraphAt :: gr s () -> LNode s -> NullCollapseViz ()
splitGraphAt gr s ()
_ LNode s
_ = () -> NullCollapseViz ()
forall a. a -> NullCollapseViz a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  finalGraph :: gr s () -> NullCollapseViz ()
finalGraph gr s ()
_ = () -> NullCollapseViz ()
forall a. a -> NullCollapseViz a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

runNullCollapse :: NullCollapseViz a -> UniqSM a
runNullCollapse :: forall a. NullCollapseViz a -> UniqSM a
runNullCollapse = NullCollapseViz a -> UniqSM a
forall a. NullCollapseViz a -> UniqSM a
unNCV


------------------ Utility functions on graphs -----------------------


-- | Tell if a `Node` has a single predecessor.
singlePred :: Graph gr => gr a b -> Node -> Bool
singlePred :: forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node -> Bool
singlePred gr a b
gr Node
n
    | ([(b, Node)
_], Node
_, a
_, Adj b
_) <- gr a b -> Node -> (Adj b, Node, a, Adj b)
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Context a b
context gr a b
gr Node
n = Bool
True
    | Bool
otherwise = Bool
False

-- | Use this function to extract information about a `Node` that you
-- know is in a `Graph`.  It's like `match` from `Graph`, but it must
-- succeed.
forceMatch :: (Graph gr)
           => Node -> gr s b -> (Context s b, gr s b)
forceMatch :: forall (gr :: * -> * -> *) s b.
Graph gr =>
Node -> gr s b -> (Context s b, gr s b)
forceMatch Node
node gr s b
g = case Node -> gr s b -> Decomp gr s b
forall a b. Node -> gr a b -> Decomp gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
Node -> gr a b -> Decomp gr a b
match Node
node gr s b
g of (Just Context s b
c, gr s b
g') -> (Context s b
c, gr s b
g')
                                         Decomp gr s b
_ -> Node -> gr s b -> (Context s b, gr s b)
forall (gr :: * -> * -> *) s b any.
Graph gr =>
Node -> gr s b -> any
panicDump Node
node gr s b
g
 where panicDump :: Graph gr => Node -> gr s b -> any
       panicDump :: forall (gr :: * -> * -> *) s b any.
Graph gr =>
Node -> gr s b -> any
panicDump Node
k gr s b
_g =
         String -> any
forall a. HasCallStack => String -> a
panic (String -> any) -> String -> any
forall a b. (a -> b) -> a -> b
$ String
"GHC.Data.Graph.Collapse failed to match node " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Node -> String
forall a. Show a => a -> String
show Node
k

-- | Rewrite the label of a given node.
updateNode :: DynGraph gr => (s -> s) -> Node -> gr s b -> gr s b
updateNode :: forall (gr :: * -> * -> *) s b.
DynGraph gr =>
(s -> s) -> Node -> gr s b -> gr s b
updateNode s -> s
relabel Node
node gr s b
g = (Adj b
preds, Node
n, s -> s
relabel s
this, Adj b
succs) Context s b -> gr s b -> gr s b
forall a b. Context a b -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr s b
g'
    where ((Adj b
preds, Node
n, s
this, Adj b
succs), gr s b
g') = Node -> gr s b -> (Context s b, gr s b)
forall (gr :: * -> * -> *) s b.
Graph gr =>
Node -> gr s b -> (Context s b, gr s b)
forceMatch Node
node gr s b
g


-- | Test if a graph has but a single node.
singletonGraph :: Graph gr => gr a b -> Bool
singletonGraph :: forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
singletonGraph gr a b
g = case gr a b -> [LNode a]
forall a b. gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr a b
g of [LNode a
_] -> Bool
True
                                      [LNode a]
_ -> Bool
False


----------------  Supernodes ------------------------------------

-- | A "supernode" stands for a collection of one or more nodes (basic
-- blocks) that have been coalesced by the Hecht-Ullman algorithm.
-- A collection in a supernode constitutes a /reducible/ subgraph of a
-- control-flow graph.  (When an entire control-flow graph is collapsed
-- to a single supernode, the flow graph is reducible.)
--
-- The idea of node splitting is to collapse a control-flow graph down
-- to a single supernode, then materialize (``inflate'') the reducible
-- equivalent graph from that supernode.  The `Supernode` class
-- defines only the methods needed to collapse; rematerialization is
-- the responsiblity of the client.
--
-- During the Hecht-Ullman algorithm, every supernode has a unique
-- entry point, which is given by `superLabel`.  But this invariant is
-- not guaranteed by the class methods and is not a law of the class.
-- The `mapLabels` function rewrites all labels that appear in a
-- supernode (both definitions and uses).  The `freshen` function
-- replaces every appearance of a /defined/ label with a fresh label.
-- (Appearances include both definitions and uses.)
--
-- Laws:
-- @
--    superLabel (n <> n') == superLabel n
--    blocks (n <> n') == blocks n `union` blocks n'
--    mapLabels f (n <> n') = mapLabels f n <> mapLabels f n'
--    mapLabels id == id
--    mapLabels (f . g) == mapLabels f . mapLabels g
-- @
--
-- (We expect `freshen` to distribute over `<>`, but because of
-- the fresh names involved, formulating a precise law is a bit
-- challenging.)

class (Semigroup node) => PureSupernode node where
  superLabel :: node -> Label
  mapLabels :: (Label -> Label) -> (node -> node)

class (MonadUnique m, PureSupernode node) => Supernode node m where
  freshen :: node -> m node

  -- ghost method
  -- blocks :: node -> Set Block

------------------ Functions specific to the algorithm -----------------------

-- | Merge two nodes, return new graph plus list of nodes that newly have a single
-- predecessor.  This function implements transformation $T_2$ from
-- the Hecht and Ullman paper (merge the node into its unique
-- predecessor).  It then also removes self-edges (transformation $T_1$ from
-- the Hecht and Ullman paper).  There is no need for a separate
-- implementation of $T_1$.
--
-- `consumeBy v u g` returns the graph that results when node v is
-- consumed by node u in graph g.  Both v and u are replaced with a new node u'
-- with these properties:
--
--    LABELS(u') = LABELS(u) `union` LABELS(v)
--    SUCC(u') = SUCC(u) `union` SUCC(v) - { u }
--    every node that previously points to u now points to u'
--
-- It also returns a list of nodes in the result graph that
-- are *newly* single-predecessor nodes.

consumeBy :: (DynGraph gr, PureSupernode s)
          => Node -> Node -> gr s () -> (gr s (), [Node])
consumeBy :: forall (gr :: * -> * -> *) s.
(DynGraph gr, PureSupernode s) =>
Node -> Node -> gr s () -> (gr s (), [Node])
consumeBy Node
toNode Node
fromNode gr s ()
g =
    Bool -> (gr s (), [Node]) -> (gr s (), [Node])
forall a. HasCallStack => Bool -> a -> a
assert (Adj ()
toPreds Adj () -> Adj () -> Bool
forall a. Eq a => a -> a -> Bool
== [((), Node
fromNode)]) ((gr s (), [Node]) -> (gr s (), [Node]))
-> (gr s (), [Node]) -> (gr s (), [Node])
forall a b. (a -> b) -> a -> b
$
    (gr s ()
newGraph, [Node]
newCandidates)
  where ((Adj ()
toPreds,   Node
_, s
to,   Adj ()
toSuccs),   gr s ()
g')  = Node -> gr s () -> (Context s (), gr s ())
forall (gr :: * -> * -> *) s b.
Graph gr =>
Node -> gr s b -> (Context s b, gr s b)
forceMatch Node
toNode   gr s ()
g
        ((Adj ()
fromPreds, Node
_, s
from, Adj ()
fromSuccs), gr s ()
g'') = Node -> gr s () -> (Context s (), gr s ())
forall (gr :: * -> * -> *) s b.
Graph gr =>
Node -> gr s b -> (Context s b, gr s b)
forceMatch Node
fromNode gr s ()
g'
        context :: Context s ()
context = ( Adj ()
fromPreds -- by construction, can't have `toNode`
                  , Node
fromNode
                  , s
from s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
to
                  , ((), Node) -> Adj () -> Adj ()
forall a. Eq a => a -> [a] -> [a]
delete ((), Node
fromNode) Adj ()
toSuccs Adj () -> Adj () -> Adj ()
forall a. Eq a => [a] -> [a] -> [a]
`union` Adj ()
fromSuccs
                  )
        newGraph :: gr s ()
newGraph = Context s ()
context Context s () -> gr s () -> gr s ()
forall a b. Context a b -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr s ()
g''
        newCandidates :: [Node]
newCandidates = (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter (gr s () -> Node -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node -> Bool
singlePred gr s ()
newGraph) [Node]
changedNodes
        changedNodes :: [Node]
changedNodes = Node
fromNode Node -> [Node] -> [Node]
forall a. Ord a => a -> [a] -> [a]
`insert` (((), Node) -> Node) -> Adj () -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map ((), Node) -> Node
forall a b. (a, b) -> b
snd (Adj ()
toSuccs Adj () -> Adj () -> Adj ()
forall a. Eq a => [a] -> [a] -> [a]
`intersect` Adj ()
fromSuccs)

-- | Split a given node.  The node is replaced with a collection of replicas,
-- one for each predecessor.  After the split, every predecessor
-- points to a unique replica.
split :: forall gr s b m . (DynGraph gr, Supernode s m)
      => Node -> gr s b -> m (gr s b)
split :: forall (gr :: * -> * -> *) s b (m :: * -> *).
(DynGraph gr, Supernode s m) =>
Node -> gr s b -> m (gr s b)
split Node
node gr s b
g = Bool -> m (gr s b) -> m (gr s b)
forall a. HasCallStack => Bool -> a -> a
assert ([(b, Node)] -> Bool
forall a. [a] -> Bool
isMultiple [(b, Node)]
preds) (m (gr s b) -> m (gr s b)) -> m (gr s b) -> m (gr s b)
forall a b. (a -> b) -> a -> b
$ (gr s b -> ((b, Node), Node) -> m (gr s b))
-> gr s b -> [((b, Node), Node)] -> m (gr s b)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM gr s b -> ((b, Node), Node) -> m (gr s b)
addReplica gr s b
g' [((b, Node), Node)]
newNodes
  where (([(b, Node)]
preds, Node
_, s
this, [(b, Node)]
succs), gr s b
g') = Node -> gr s b -> (Context s b, gr s b)
forall (gr :: * -> * -> *) s b.
Graph gr =>
Node -> gr s b -> (Context s b, gr s b)
forceMatch Node
node gr s b
g
        newNodes :: [((b, Node), Node)]
        newNodes :: [((b, Node), Node)]
newNodes = [(b, Node)] -> [Node] -> [((b, Node), Node)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(b, Node)]
preds [Node
maxNodeNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
1..]
        (Node
_, Node
maxNode) = gr s b -> (Node, Node)
forall a b. gr a b -> (Node, Node)
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> (Node, Node)
nodeRange gr s b
g
        thisLabel :: Label
thisLabel = s -> Label
forall node. PureSupernode node => node -> Label
superLabel s
this
        addReplica :: gr s b -> ((b, Node), Node) -> m (gr s b)
        addReplica :: gr s b -> ((b, Node), Node) -> m (gr s b)
addReplica gr s b
g ((b
b, Node
pred), Node
newNode) = do
            s
newSuper <- s -> m s
forall node (m :: * -> *). Supernode node m => node -> m node
freshen s
this
            gr s b -> m (gr s b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (gr s b -> m (gr s b)) -> gr s b -> m (gr s b)
forall a b. (a -> b) -> a -> b
$ s -> gr s b
add s
newSuper
          where add :: s -> gr s b
add s
newSuper =
                  (s -> s) -> Node -> gr s b -> gr s b
forall (gr :: * -> * -> *) s b.
DynGraph gr =>
(s -> s) -> Node -> gr s b -> gr s b
updateNode (Label
thisLabel Label -> Label -> s -> s
forall s. PureSupernode s => Label -> Label -> s -> s
`replacedWith` s -> Label
forall node. PureSupernode node => node -> Label
superLabel s
newSuper) Node
pred (gr s b -> gr s b) -> gr s b -> gr s b
forall a b. (a -> b) -> a -> b
$
                  ([(b
b, Node
pred)], Node
newNode, s
newSuper, [(b, Node)]
succs) Context s b -> gr s b -> gr s b
forall a b. Context a b -> gr a b -> gr a b
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
Context a b -> gr a b -> gr a b
& gr s b
g

replacedWith :: PureSupernode s => Label -> Label -> s -> s
replacedWith :: forall s. PureSupernode s => Label -> Label -> s -> s
replacedWith Label
old Label
new = (Label -> Label) -> s -> s
forall node. PureSupernode node => (Label -> Label) -> node -> node
mapLabels (\Label
l -> if Label
l Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
old then Label
new else Label
l)


-- | Does a list have more than one element? (in constant time).
isMultiple :: [a] -> Bool
isMultiple :: forall a. [a] -> Bool
isMultiple [] = Bool
False
isMultiple [a
_] = Bool
False
isMultiple (a
_:a
_:[a]
_) = Bool
True

-- | Find a candidate for splitting by finding a node that has multiple predecessors.

anySplittable :: forall gr a b . Graph gr => gr a b -> LNode a
anySplittable :: forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> LNode a
anySplittable gr a b
g = case [LNode a]
splittable of
                    LNode a
n : [LNode a]
_ -> LNode a
n
                    [] -> String -> LNode a
forall a. HasCallStack => String -> a
panic String
"anySplittable found no splittable nodes"
  where splittable :: [LNode a]
splittable = (LNode a -> Bool) -> [LNode a] -> [LNode a]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Node] -> Bool
forall a. [a] -> Bool
isMultiple ([Node] -> Bool) -> (LNode a -> [Node]) -> LNode a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. gr a b -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
pre gr a b
g (Node -> [Node]) -> (LNode a -> Node) -> LNode a -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LNode a -> Node
forall a b. (a, b) -> a
fst) ([LNode a] -> [LNode a]) -> [LNode a] -> [LNode a]
forall a b. (a -> b) -> a -> b
$ gr a b -> [LNode a]
forall a b. gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr a b
g
        splittable :: [LNode a]


------------------ The collapsing algorithm -----------------------

-- | Using the algorithm of Hecht and Ullman (1972), collapse a graph
-- into a single node, splitting nodes as needed.  Record
-- visualization events in monad `m`.
collapseInductiveGraph :: (DynGraph gr, Supernode s m, VizCollapseMonad m gr s)
                       => gr s () -> m (gr s ())
collapseInductiveGraph :: forall (gr :: * -> * -> *) s (m :: * -> *).
(DynGraph gr, Supernode s m, VizCollapseMonad m gr s) =>
gr s () -> m (gr s ())
collapseInductiveGraph gr s ()
g = gr s () -> [[Node]] -> m (gr s ())
forall {gr :: * -> * -> *} {m :: * -> *} {s}.
(VizCollapseMonad m gr s, DynGraph gr) =>
gr s () -> [[Node]] -> m (gr s ())
drain gr s ()
g [[Node]]
worklist
  where worklist :: [[Node]] -- nodes with exactly one predecessor
        worklist :: [[Node]]
worklist = [(Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter (gr s () -> Node -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Node -> Bool
singlePred gr s ()
g) ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ gr s () -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
nodes gr s ()
g]

        drain :: gr s () -> [[Node]] -> m (gr s ())
drain gr s ()
g [] = if gr s () -> Bool
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Bool
singletonGraph gr s ()
g then gr s () -> m ()
forall (m :: * -> *) (gr :: * -> * -> *) s.
VizCollapseMonad m gr s =>
gr s () -> m ()
finalGraph gr s ()
g m () -> m (gr s ()) -> m (gr s ())
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> gr s () -> m (gr s ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return gr s ()
g
                     else let (Node
n, s
super) = gr s () -> (Node, s)
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> LNode a
anySplittable gr s ()
g
                          in  do gr s () -> (Node, s) -> m ()
forall (m :: * -> *) (gr :: * -> * -> *) s.
VizCollapseMonad m gr s =>
gr s () -> LNode s -> m ()
splitGraphAt gr s ()
g (Node
n, s
super)
                                 gr s () -> m (gr s ())
forall (gr :: * -> * -> *) s (m :: * -> *).
(DynGraph gr, Supernode s m, VizCollapseMonad m gr s) =>
gr s () -> m (gr s ())
collapseInductiveGraph (gr s () -> m (gr s ())) -> m (gr s ()) -> m (gr s ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node -> gr s () -> m (gr s ())
forall (gr :: * -> * -> *) s b (m :: * -> *).
(DynGraph gr, Supernode s m) =>
Node -> gr s b -> m (gr s b)
split Node
n gr s ()
g
        drain gr s ()
g ([]:[[Node]]
nss) = gr s () -> [[Node]] -> m (gr s ())
drain gr s ()
g [[Node]]
nss
        drain gr s ()
g ((Node
n:[Node]
ns):[[Node]]
nss) = let (gr s ()
g', [Node]
ns') = Node -> Node -> gr s () -> (gr s (), [Node])
forall (gr :: * -> * -> *) s.
(DynGraph gr, PureSupernode s) =>
Node -> Node -> gr s () -> (gr s (), [Node])
consumeBy Node
n (Node -> Node
theUniquePred Node
n) gr s ()
g
                               in  do Node -> Node -> gr s () -> m ()
forall (m :: * -> *) (gr :: * -> * -> *) s.
VizCollapseMonad m gr s =>
Node -> Node -> gr s () -> m ()
consumeByInGraph Node
n (Node -> Node
theUniquePred Node
n) gr s ()
g
                                      gr s () -> [[Node]] -> m (gr s ())
drain gr s ()
g' ([Node]
ns'[Node] -> [[Node]] -> [[Node]]
forall a. a -> [a] -> [a]
:[Node]
ns[Node] -> [[Node]] -> [[Node]]
forall a. a -> [a] -> [a]
:[[Node]]
nss)
         where theUniquePred :: Node -> Node
theUniquePred Node
n
                 | ([(()
_, Node
p)], Node
_, s
_, Adj ()
_) <- gr s () -> Node -> (Adj (), Node, s, Adj ())
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> Context a b
context gr s ()
g Node
n = Node
p
                 | Bool
otherwise =
                     String -> Node
forall a. HasCallStack => String -> a
panic String
"node claimed to have a unique predecessor; it doesn't"