{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Cubix.Language.Parametric.Semantics.Cfg.CommonNodes (
    constructCfgReturn
  , constructCfgEmpty
  , constructCfgIfElseIfElse

  , LoopStack
  , emptyLoopStack
  , HasLoopStack(..)
  , pushContinueNode
  , popContinueNode
  , pushBreakNode
  , popBreakNode
  , pushLoopNode
  , popLoopNode
  , constructCfgWhile
  , constructCfgDoWhile
  , constructCfgFor
  , constructCfgBreak
  , constructCfgContinue

  , LabelMap
  , emptyLabelMap
  , HasLabelMap(..)
  , constructCfgGoto
  , constructCfgLabel

  , ScopedLabelMap
  , emptyScopedLabelMap
  , HasScopedLabelMap(..)
  , withScopedLabel
  , edgeToScopedLabel
  , constructCfgScopedLabeledBreak
  , constructCfgScopedLabeledContinue
  , constructCfgScopedLabel

  , constructCfgShortCircuitingBinOp
  , constructCfgCondOp

) where

import Control.Monad ( liftM, when )
import Control.Monad.State ( MonadState )

import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Proxy ( Proxy(..) )
import Data.Traversable ( for )

import Control.Lens ( (^.), (%~), (%=), (.=), (.~), _2, at, use, makeClassy )

import Data.Comp.Multi ( HTraversable(..), All, HFunctor, HFoldable )

import Cubix.Language.Info
import Cubix.Language.Parametric.Semantics.Cfg.CfgConstruction
import Cubix.Language.Parametric.Semantics.Cfg.Graph
import Cubix.Language.Parametric.Semantics.SemanticProperties

--------------------------------------------------------------------------------------

eeNonEmpty :: EnterExitPair fs i -> Bool
eeNonEmpty :: EnterExitPair fs i -> Bool
eeNonEmpty (EnterExitPair _ _) = Bool
True
eeNonEmpty EmptyEnterExit      = Bool
False
eeNonEmpty _                   = [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error "Passed non-collapsed EnterExitPair to eeNonEmpty"

collapseMaybeEnterExit :: Maybe (EnterExitPair fs i) -> EnterExitPair fs i
collapseMaybeEnterExit :: Maybe (EnterExitPair fs i) -> EnterExitPair fs i
collapseMaybeEnterExit (Just eep :: EnterExitPair fs i
eep) = EnterExitPair fs i
eep
collapseMaybeEnterExit Nothing    = EnterExitPair fs i
forall (fs :: [(* -> *) -> * -> *]) l. EnterExitPair fs l
EmptyEnterExit

mCombineEnterExit ::
  ( HasCurCfg s fs
  , MonadState s m
  , All HTraversable fs
  , All HFunctor fs
  , All HFoldable fs
  ) => m (EnterExitPair fs i) -> EnterExitPair fs j -> m (EnterExitPair fs k)
mCombineEnterExit :: m (EnterExitPair fs i)
-> EnterExitPair fs j -> m (EnterExitPair fs k)
mCombineEnterExit p1 :: m (EnterExitPair fs i)
p1 p2 :: EnterExitPair fs j
p2 = m (EnterExitPair fs i)
p1 m (EnterExitPair fs i)
-> (EnterExitPair fs i -> m (EnterExitPair fs k))
-> m (EnterExitPair fs k)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\r :: EnterExitPair fs i
r -> EnterExitPair fs i -> EnterExitPair fs j -> m (EnterExitPair fs k)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j k.
(HasCurCfg s fs, All HTraversable fs, All HFoldable fs,
 All HFunctor fs, MonadState s m) =>
EnterExitPair fs i -> EnterExitPair fs j -> m (EnterExitPair fs k)
combineEnterExit EnterExitPair fs i
r EnterExitPair fs j
p2)

--------------------------------------------------------------------------------------

-- Because we don't actually have function start and end nodes,
-- for now we can model "return" as just a black hole with no outgoing edges
-- This can also model the computed goto in GCC
constructCfgReturn ::
  ( MonadState s m
  , CfgComponent gs s
  ) => TermLab gs l -> m (Maybe (EnterExitPair gs i)) -> m (EnterExitPair gs l)
constructCfgReturn :: TermLab gs l
-> m (Maybe (EnterExitPair gs i)) -> m (EnterExitPair gs l)
constructCfgReturn t :: TermLab gs l
t exp :: m (Maybe (EnterExitPair gs i))
exp = do
  CfgNode gs
enterNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
EnterNode
  CfgNode gs
exitNode  <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode
  EnterExitPair gs i
e <- (Maybe (EnterExitPair gs i) -> EnterExitPair gs i)
-> m (Maybe (EnterExitPair gs i)) -> m (EnterExitPair gs i)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe (EnterExitPair gs i) -> EnterExitPair gs i
forall (fs :: [(* -> *) -> * -> *]) i.
Maybe (EnterExitPair fs i) -> EnterExitPair fs i
collapseMaybeEnterExit m (Maybe (EnterExitPair gs i))
exp
  EnterExitPair gs Any
-> EnterExitPair gs i -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j k.
(HasCurCfg s fs, All HTraversable fs, All HFoldable fs,
 All HFunctor fs, MonadState s m) =>
EnterExitPair fs i -> EnterExitPair fs j -> m (EnterExitPair fs k)
combineEnterExit (CfgNode gs -> EnterExitPair gs Any
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> EnterExitPair fs l
identEnterExit CfgNode gs
enterNode) EnterExitPair gs i
e
  EnterExitPair gs l -> m (EnterExitPair gs l)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs l -> m (EnterExitPair gs l))
-> EnterExitPair gs l -> m (EnterExitPair gs l)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs l
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode

constructCfgEmpty :: (MonadState s m, CfgComponent gs s) => TermLab gs l -> m (EnterExitPair gs l)
constructCfgEmpty :: TermLab gs l -> m (EnterExitPair gs l)
constructCfgEmpty t :: TermLab gs l
t = do
  CfgNode gs
enterNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
EnterNode
  CfgNode gs
exitNode  <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode
  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
enterNode CfgNode gs
exitNode
  EnterExitPair gs l -> m (EnterExitPair gs l)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs l -> m (EnterExitPair gs l))
-> EnterExitPair gs l -> m (EnterExitPair gs l)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs l
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode


constructCfgIfElseIfElse ::
  ( MonadState s m
  , CfgComponent gs s
  ) => TermLab gs l -> m [(EnterExitPair gs i, EnterExitPair gs j)] -> m (Maybe (EnterExitPair gs k)) -> m (EnterExitPair gs l)
constructCfgIfElseIfElse :: TermLab gs l
-> m [(EnterExitPair gs i, EnterExitPair gs j)]
-> m (Maybe (EnterExitPair gs k))
-> m (EnterExitPair gs l)
constructCfgIfElseIfElse t :: TermLab gs l
t clauses :: m [(EnterExitPair gs i, EnterExitPair gs j)]
clauses optElse :: m (Maybe (EnterExitPair gs k))
optElse = do
  CfgNode gs
enterNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
EnterNode
  [(EnterExitPair gs i, EnterExitPair gs j)]
evalledClauses <- m [(EnterExitPair gs i, EnterExitPair gs j)]
clauses

  [CfgNode gs]
midNodes <- [Int] -> (Int -> m (CfgNode gs)) -> m [CfgNode gs]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [0..([(EnterExitPair gs i, EnterExitPair gs j)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(EnterExitPair gs i, EnterExitPair gs j)]
evalledClauses Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)] ((Int -> m (CfgNode gs)) -> m [CfgNode gs])
-> (Int -> m (CfgNode gs)) -> m [CfgNode gs]
forall a b. (a -> b) -> a -> b
$ \i :: Int
i ->
                        TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t (NodeEvaluationPoint -> CfgNodeType
evalPointToNodeType (Int -> NodeEvaluationPoint
BeforeIntermediateEvalPoint Int
i))

  CfgNode gs
exitNode  <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode

  [(EnterExitPair gs i, EnterExitPair gs j)]
-> ((EnterExitPair gs i, EnterExitPair gs j) -> m ()) -> m [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(EnterExitPair gs i, EnterExitPair gs j)]
evalledClauses (((EnterExitPair gs i, EnterExitPair gs j) -> m ()) -> m [()])
-> ((EnterExitPair gs i, EnterExitPair gs j) -> m ()) -> m [()]
forall a b. (a -> b) -> a -> b
$ \(c :: EnterExitPair gs i
c, b :: EnterExitPair gs j
b) -> do
    (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair gs i -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair gs i
c) (EnterExitPair gs j -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair gs j
b)
    (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair gs j -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair gs j
b) CfgNode gs
exitNode

  let condNodes :: [(CfgNode gs, EnterExitPair gs i)]
condNodes = [CfgNode gs]
-> [EnterExitPair gs i] -> [(CfgNode gs, EnterExitPair gs i)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CfgNode gs]
midNodes (((EnterExitPair gs i, EnterExitPair gs j) -> EnterExitPair gs i)
-> [(EnterExitPair gs i, EnterExitPair gs j)]
-> [EnterExitPair gs i]
forall a b. (a -> b) -> [a] -> [b]
map (EnterExitPair gs i, EnterExitPair gs j) -> EnterExitPair gs i
forall a b. (a, b) -> a
fst [(EnterExitPair gs i, EnterExitPair gs j)]
evalledClauses)
  let condPairs :: [((CfgNode gs, EnterExitPair gs i),
  (CfgNode gs, EnterExitPair gs i))]
condPairs = [(CfgNode gs, EnterExitPair gs i)]
-> [(CfgNode gs, EnterExitPair gs i)]
-> [((CfgNode gs, EnterExitPair gs i),
     (CfgNode gs, EnterExitPair gs i))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(CfgNode gs, EnterExitPair gs i)]
condNodes ([(CfgNode gs, EnterExitPair gs i)]
-> [(CfgNode gs, EnterExitPair gs i)]
forall a. [a] -> [a]
tail [(CfgNode gs, EnterExitPair gs i)]
condNodes)

  [(CfgNode gs, EnterExitPair gs i)]
-> ((CfgNode gs, EnterExitPair gs i) -> m ()) -> m [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(CfgNode gs, EnterExitPair gs i)]
condNodes (((CfgNode gs, EnterExitPair gs i) -> m ()) -> m [()])
-> ((CfgNode gs, EnterExitPair gs i) -> m ()) -> m [()]
forall a b. (a -> b) -> a -> b
$ \(n :: CfgNode gs
n, x :: EnterExitPair gs i
x) -> (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
n (EnterExitPair gs i -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair gs i
x)

  [((CfgNode gs, EnterExitPair gs i),
  (CfgNode gs, EnterExitPair gs i))]
-> (((CfgNode gs, EnterExitPair gs i),
     (CfgNode gs, EnterExitPair gs i))
    -> m ())
-> m [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [((CfgNode gs, EnterExitPair gs i),
  (CfgNode gs, EnterExitPair gs i))]
condPairs ((((CfgNode gs, EnterExitPair gs i),
   (CfgNode gs, EnterExitPair gs i))
  -> m ())
 -> m [()])
-> (((CfgNode gs, EnterExitPair gs i),
     (CfgNode gs, EnterExitPair gs i))
    -> m ())
-> m [()]
forall a b. (a -> b) -> a -> b
$ \((xn :: CfgNode gs
xn, x :: EnterExitPair gs i
x), (yn :: CfgNode gs
yn, y :: EnterExitPair gs i
y)) -> do
    (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair gs i -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair gs i
x) CfgNode gs
yn

  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
enterNode ([CfgNode gs] -> CfgNode gs
forall a. [a] -> a
head [CfgNode gs]
midNodes)

  Maybe (EnterExitPair gs k)
evalledOptElse <- m (Maybe (EnterExitPair gs k))
optElse
  let lastCondExit :: CfgNode gs
lastCondExit = EnterExitPair gs i -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit (EnterExitPair gs i -> CfgNode gs)
-> EnterExitPair gs i -> CfgNode gs
forall a b. (a -> b) -> a -> b
$ (EnterExitPair gs i, EnterExitPair gs j) -> EnterExitPair gs i
forall a b. (a, b) -> a
fst ((EnterExitPair gs i, EnterExitPair gs j) -> EnterExitPair gs i)
-> (EnterExitPair gs i, EnterExitPair gs j) -> EnterExitPair gs i
forall a b. (a -> b) -> a -> b
$ [(EnterExitPair gs i, EnterExitPair gs j)]
-> (EnterExitPair gs i, EnterExitPair gs j)
forall a. [a] -> a
last [(EnterExitPair gs i, EnterExitPair gs j)]
evalledClauses

  case Maybe (EnterExitPair gs k)
evalledOptElse of
    Nothing             -> (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
lastCondExit CfgNode gs
exitNode
    Just c :: EnterExitPair gs k
c              -> EnterExitPair gs k -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j.
(HasCurCfg s fs, All HTraversable fs, All HFoldable fs,
 All HFunctor fs, MonadState s m) =>
EnterExitPair fs i -> m (EnterExitPair fs j)
collapseEnterExit EnterExitPair gs k
c m (EnterExitPair gs Any) -> (EnterExitPair gs Any -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \c' :: EnterExitPair gs Any
c' -> case EnterExitPair gs Any
c' of
            EmptyEnterExit       -> (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
lastCondExit CfgNode gs
exitNode
            EnterExitPair ent :: CfgNode gs
ent ex :: CfgNode gs
ex -> do
               (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
lastCondExit CfgNode gs
ent
               (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
ex CfgNode gs
exitNode

  EnterExitPair gs l -> m (EnterExitPair gs l)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs l -> m (EnterExitPair gs l))
-> EnterExitPair gs l -> m (EnterExitPair gs l)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs l
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode


data LoopStack = LoopStack {
         LoopStack -> [Label]
_break_stack :: [Label]
       , LoopStack -> [Label]
_continue_stack :: [Label]
       }
  deriving ( LoopStack -> LoopStack -> Bool
(LoopStack -> LoopStack -> Bool)
-> (LoopStack -> LoopStack -> Bool) -> Eq LoopStack
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LoopStack -> LoopStack -> Bool
$c/= :: LoopStack -> LoopStack -> Bool
== :: LoopStack -> LoopStack -> Bool
$c== :: LoopStack -> LoopStack -> Bool
Eq, Eq LoopStack
Eq LoopStack =>
(LoopStack -> LoopStack -> Ordering)
-> (LoopStack -> LoopStack -> Bool)
-> (LoopStack -> LoopStack -> Bool)
-> (LoopStack -> LoopStack -> Bool)
-> (LoopStack -> LoopStack -> Bool)
-> (LoopStack -> LoopStack -> LoopStack)
-> (LoopStack -> LoopStack -> LoopStack)
-> Ord LoopStack
LoopStack -> LoopStack -> Bool
LoopStack -> LoopStack -> Ordering
LoopStack -> LoopStack -> LoopStack
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 :: LoopStack -> LoopStack -> LoopStack
$cmin :: LoopStack -> LoopStack -> LoopStack
max :: LoopStack -> LoopStack -> LoopStack
$cmax :: LoopStack -> LoopStack -> LoopStack
>= :: LoopStack -> LoopStack -> Bool
$c>= :: LoopStack -> LoopStack -> Bool
> :: LoopStack -> LoopStack -> Bool
$c> :: LoopStack -> LoopStack -> Bool
<= :: LoopStack -> LoopStack -> Bool
$c<= :: LoopStack -> LoopStack -> Bool
< :: LoopStack -> LoopStack -> Bool
$c< :: LoopStack -> LoopStack -> Bool
compare :: LoopStack -> LoopStack -> Ordering
$ccompare :: LoopStack -> LoopStack -> Ordering
$cp1Ord :: Eq LoopStack
Ord, Int -> LoopStack -> ShowS
[LoopStack] -> ShowS
LoopStack -> [Char]
(Int -> LoopStack -> ShowS)
-> (LoopStack -> [Char])
-> ([LoopStack] -> ShowS)
-> Show LoopStack
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LoopStack] -> ShowS
$cshowList :: [LoopStack] -> ShowS
show :: LoopStack -> [Char]
$cshow :: LoopStack -> [Char]
showsPrec :: Int -> LoopStack -> ShowS
$cshowsPrec :: Int -> LoopStack -> ShowS
Show )

emptyLoopStack :: LoopStack
emptyLoopStack :: LoopStack
emptyLoopStack = [Label] -> [Label] -> LoopStack
LoopStack [] []

makeClassy ''LoopStack

pushBreakNode :: (MonadState s m, HasLoopStack s) => CfgNode fs -> m ()
pushBreakNode :: CfgNode fs -> m ()
pushBreakNode n :: CfgNode fs
n = ([Label] -> Identity [Label]) -> s -> Identity s
forall c. HasLoopStack c => Lens' c [Label]
break_stack (([Label] -> Identity [Label]) -> s -> Identity s)
-> ([Label] -> [Label]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ((CfgNode fs
n CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab)Label -> [Label] -> [Label]
forall a. a -> [a] -> [a]
:)

popBreakNode :: (MonadState s m, HasLoopStack s) => m ()
popBreakNode :: m ()
popBreakNode = ([Label] -> Identity [Label]) -> s -> Identity s
forall c. HasLoopStack c => Lens' c [Label]
break_stack (([Label] -> Identity [Label]) -> s -> Identity s)
-> ([Label] -> [Label]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= [Label] -> [Label]
forall a. [a] -> [a]
tail

pushContinueNode :: (MonadState s m, HasLoopStack s) => CfgNode fs -> m ()
pushContinueNode :: CfgNode fs -> m ()
pushContinueNode n :: CfgNode fs
n = ([Label] -> Identity [Label]) -> s -> Identity s
forall c. HasLoopStack c => Lens' c [Label]
continue_stack (([Label] -> Identity [Label]) -> s -> Identity s)
-> ([Label] -> [Label]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ((CfgNode fs
n CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab)Label -> [Label] -> [Label]
forall a. a -> [a] -> [a]
:)

popContinueNode :: (MonadState s m, HasLoopStack s) => m ()
popContinueNode :: m ()
popContinueNode = ([Label] -> Identity [Label]) -> s -> Identity s
forall c. HasLoopStack c => Lens' c [Label]
continue_stack (([Label] -> Identity [Label]) -> s -> Identity s)
-> ([Label] -> [Label]) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= [Label] -> [Label]
forall a. [a] -> [a]
tail

pushLoopNode :: (MonadState s m, HasLoopStack s) => CfgNode fs -> CfgNode fs -> m ()
pushLoopNode :: CfgNode fs -> CfgNode fs -> m ()
pushLoopNode n1 :: CfgNode fs
n1 n2 :: CfgNode fs
n2 = CfgNode fs -> m ()
forall s (m :: * -> *) (fs :: [(* -> *) -> * -> *]).
(MonadState s m, HasLoopStack s) =>
CfgNode fs -> m ()
pushContinueNode CfgNode fs
n1 m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CfgNode fs -> m ()
forall s (m :: * -> *) (fs :: [(* -> *) -> * -> *]).
(MonadState s m, HasLoopStack s) =>
CfgNode fs -> m ()
pushBreakNode CfgNode fs
n2

popLoopNode :: (MonadState s m, HasLoopStack s) => m ()
popLoopNode :: m ()
popLoopNode = m ()
forall s (m :: * -> *). (MonadState s m, HasLoopStack s) => m ()
popContinueNode m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall s (m :: * -> *). (MonadState s m, HasLoopStack s) => m ()
popBreakNode

constructCfgWhile ::
  ( HasLoopStack s
  , MonadState s m
  , CfgComponent gs s
  ) => TermLab gs l -> m (EnterExitPair gs i) -> m (EnterExitPair gs j) -> m (EnterExitPair gs k)
constructCfgWhile :: TermLab gs l
-> m (EnterExitPair gs i)
-> m (EnterExitPair gs j)
-> m (EnterExitPair gs k)
constructCfgWhile t :: TermLab gs l
t mExp :: m (EnterExitPair gs i)
mExp mBody :: m (EnterExitPair gs j)
mBody = do
  CfgNode gs
enterNode     <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
EnterNode
  CfgNode gs
loopEntryNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
LoopEntryNode
  CfgNode gs
exitNode      <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode

  EnterExitPair gs Any
exp <- m (EnterExitPair gs i)
mExp m (EnterExitPair gs i)
-> (EnterExitPair gs i -> m (EnterExitPair gs Any))
-> m (EnterExitPair gs Any)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EnterExitPair gs i -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j.
(HasCurCfg s fs, All HTraversable fs, All HFoldable fs,
 All HFunctor fs, MonadState s m) =>
EnterExitPair fs i -> m (EnterExitPair fs j)
collapseEnterExit
  CfgNode gs -> CfgNode gs -> m ()
forall s (m :: * -> *) (fs :: [(* -> *) -> * -> *]).
(MonadState s m, HasLoopStack s) =>
CfgNode fs -> CfgNode fs -> m ()
pushLoopNode CfgNode gs
loopEntryNode CfgNode gs
exitNode
  EnterExitPair gs j
body <- m (EnterExitPair gs j)
mBody
  m ()
forall s (m :: * -> *). (MonadState s m, HasLoopStack s) => m ()
popLoopNode

  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
enterNode CfgNode gs
loopEntryNode
  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
loopEntryNode (EnterExitPair gs Any -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair gs Any
exp)
  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair gs Any -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair gs Any
exp) (EnterExitPair gs j -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair gs j
body)
  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair gs Any -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair gs Any
exp) CfgNode gs
exitNode
  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair gs j -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair gs j
body) CfgNode gs
loopEntryNode

  EnterExitPair gs k -> m (EnterExitPair gs k)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs k -> m (EnterExitPair gs k))
-> EnterExitPair gs k -> m (EnterExitPair gs k)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs k
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode

constructCfgDoWhile ::
  ( HasLoopStack s
  , MonadState s m
  , CfgComponent gs s
  ) => TermLab gs l -> m (EnterExitPair gs i) -> m (EnterExitPair gs j) -> m (EnterExitPair gs k)
constructCfgDoWhile :: TermLab gs l
-> m (EnterExitPair gs i)
-> m (EnterExitPair gs j)
-> m (EnterExitPair gs k)
constructCfgDoWhile t :: TermLab gs l
t mExp :: m (EnterExitPair gs i)
mExp mBody :: m (EnterExitPair gs j)
mBody = do
  CfgNode gs
enterNode     <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
EnterNode
  CfgNode gs
loopEntryNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
LoopEntryNode
  CfgNode gs
exitNode      <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode

  EnterExitPair gs Any
exp <- m (EnterExitPair gs i)
mExp m (EnterExitPair gs i)
-> (EnterExitPair gs i -> m (EnterExitPair gs Any))
-> m (EnterExitPair gs Any)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EnterExitPair gs i -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j.
(HasCurCfg s fs, All HTraversable fs, All HFoldable fs,
 All HFunctor fs, MonadState s m) =>
EnterExitPair fs i -> m (EnterExitPair fs j)
collapseEnterExit
  CfgNode gs -> CfgNode gs -> m ()
forall s (m :: * -> *) (fs :: [(* -> *) -> * -> *]).
(MonadState s m, HasLoopStack s) =>
CfgNode fs -> CfgNode fs -> m ()
pushLoopNode CfgNode gs
loopEntryNode CfgNode gs
exitNode
  EnterExitPair gs j
body <- m (EnterExitPair gs j)
mBody
  m ()
forall s (m :: * -> *). (MonadState s m, HasLoopStack s) => m ()
popLoopNode

  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
enterNode     (EnterExitPair gs j -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair gs j
body)
  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair gs Any -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair gs Any
exp)    (EnterExitPair gs j -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair gs j
body)
  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair gs Any -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair gs Any
exp)    CfgNode gs
exitNode
  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair gs j -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair gs j
body)   CfgNode gs
loopEntryNode
  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
loopEntryNode (EnterExitPair gs Any -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair gs Any
exp)

  EnterExitPair gs k -> m (EnterExitPair gs k)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs k -> m (EnterExitPair gs k))
-> EnterExitPair gs k -> m (EnterExitPair gs k)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs k
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode

constructCfgFor ::
  ( HasLoopStack s
  , MonadState s m
  , CfgComponent gs s
  ) => TermLab gs l
  -> m (Maybe (EnterExitPair gs h))
  -> m (Maybe (EnterExitPair gs i))
  -> m (Maybe (EnterExitPair gs j))
  -> m (EnterExitPair gs k)
  -> m (EnterExitPair gs l)
constructCfgFor :: TermLab gs l
-> m (Maybe (EnterExitPair gs h))
-> m (Maybe (EnterExitPair gs i))
-> m (Maybe (EnterExitPair gs j))
-> m (EnterExitPair gs k)
-> m (EnterExitPair gs l)
constructCfgFor t :: TermLab gs l
t mInit :: m (Maybe (EnterExitPair gs h))
mInit mCond :: m (Maybe (EnterExitPair gs i))
mCond mStep :: m (Maybe (EnterExitPair gs j))
mStep mBody :: m (EnterExitPair gs k)
mBody = do
  CfgNode gs
enterNode     <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
EnterNode
  CfgNode gs
loopEntryNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
LoopEntryNode
  CfgNode gs
exitNode      <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode

  EnterExitPair gs Any
init <- EnterExitPair gs h -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j.
(HasCurCfg s fs, All HTraversable fs, All HFoldable fs,
 All HFunctor fs, MonadState s m) =>
EnterExitPair fs i -> m (EnterExitPair fs j)
collapseEnterExit (EnterExitPair gs h -> m (EnterExitPair gs Any))
-> m (EnterExitPair gs h) -> m (EnterExitPair gs Any)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Maybe (EnterExitPair gs h) -> EnterExitPair gs h)
-> m (Maybe (EnterExitPair gs h)) -> m (EnterExitPair gs h)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe (EnterExitPair gs h) -> EnterExitPair gs h
forall (fs :: [(* -> *) -> * -> *]) i.
Maybe (EnterExitPair fs i) -> EnterExitPair fs i
collapseMaybeEnterExit m (Maybe (EnterExitPair gs h))
mInit
  EnterExitPair gs Any
cond <- EnterExitPair gs i -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j.
(HasCurCfg s fs, All HTraversable fs, All HFoldable fs,
 All HFunctor fs, MonadState s m) =>
EnterExitPair fs i -> m (EnterExitPair fs j)
collapseEnterExit (EnterExitPair gs i -> m (EnterExitPair gs Any))
-> m (EnterExitPair gs i) -> m (EnterExitPair gs Any)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Maybe (EnterExitPair gs i) -> EnterExitPair gs i)
-> m (Maybe (EnterExitPair gs i)) -> m (EnterExitPair gs i)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe (EnterExitPair gs i) -> EnterExitPair gs i
forall (fs :: [(* -> *) -> * -> *]) i.
Maybe (EnterExitPair fs i) -> EnterExitPair fs i
collapseMaybeEnterExit m (Maybe (EnterExitPair gs i))
mCond
  EnterExitPair gs Any
step <- EnterExitPair gs j -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j.
(HasCurCfg s fs, All HTraversable fs, All HFoldable fs,
 All HFunctor fs, MonadState s m) =>
EnterExitPair fs i -> m (EnterExitPair fs j)
collapseEnterExit (EnterExitPair gs j -> m (EnterExitPair gs Any))
-> m (EnterExitPair gs j) -> m (EnterExitPair gs Any)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Maybe (EnterExitPair gs j) -> EnterExitPair gs j)
-> m (Maybe (EnterExitPair gs j)) -> m (EnterExitPair gs j)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe (EnterExitPair gs j) -> EnterExitPair gs j
forall (fs :: [(* -> *) -> * -> *]) i.
Maybe (EnterExitPair fs i) -> EnterExitPair fs i
collapseMaybeEnterExit m (Maybe (EnterExitPair gs j))
mStep

  EnterExitPair gs Any
initCond <- EnterExitPair gs Any
-> EnterExitPair gs Any -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j k.
(HasCurCfg s fs, All HTraversable fs, All HFoldable fs,
 All HFunctor fs, MonadState s m) =>
EnterExitPair fs i -> EnterExitPair fs j -> m (EnterExitPair fs k)
combineEnterExit EnterExitPair gs Any
init EnterExitPair gs Any
cond

  CfgNode gs -> CfgNode gs -> m ()
forall s (m :: * -> *) (fs :: [(* -> *) -> * -> *]).
(MonadState s m, HasLoopStack s) =>
CfgNode fs -> CfgNode fs -> m ()
pushLoopNode CfgNode gs
loopEntryNode CfgNode gs
exitNode
  EnterExitPair gs k
body <- m (EnterExitPair gs k)
mBody
  m ()
forall s (m :: * -> *). (MonadState s m, HasLoopStack s) => m ()
popLoopNode

  EnterExitPair gs Any
initCondBody <- EnterExitPair gs Any
-> EnterExitPair gs k -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j k.
(HasCurCfg s fs, All HTraversable fs, All HFoldable fs,
 All HFunctor fs, MonadState s m) =>
EnterExitPair fs i -> EnterExitPair fs j -> m (EnterExitPair fs k)
combineEnterExit EnterExitPair gs Any
initCond EnterExitPair gs k
body

  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
enterNode (EnterExitPair gs Any -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair gs Any
initCondBody)

  (((EnterExitPair gs k
body EnterExitPair gs k
-> EnterExitPair gs Any -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j k.
(HasCurCfg s fs, All HTraversable fs, All HFoldable fs,
 All HFunctor fs, MonadState s m) =>
EnterExitPair fs i -> EnterExitPair fs j -> m (EnterExitPair fs k)
`combineEnterExit`  (CfgNode gs -> EnterExitPair gs Any
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> EnterExitPair fs l
identEnterExit CfgNode gs
loopEntryNode))
          m (EnterExitPair gs Any)
-> EnterExitPair gs Any -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j k.
(HasCurCfg s fs, MonadState s m, All HTraversable fs,
 All HFunctor fs, All HFoldable fs) =>
m (EnterExitPair fs i)
-> EnterExitPair fs j -> m (EnterExitPair fs k)
`mCombineEnterExit` EnterExitPair gs Any
step)
          m (EnterExitPair gs Any)
-> EnterExitPair gs Any -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j k.
(HasCurCfg s fs, MonadState s m, All HTraversable fs,
 All HFunctor fs, All HFoldable fs) =>
m (EnterExitPair fs i)
-> EnterExitPair fs j -> m (EnterExitPair fs k)
`mCombineEnterExit` EnterExitPair gs Any
cond)
          m (EnterExitPair gs Any)
-> EnterExitPair gs k -> m (EnterExitPair gs Any)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) i j k.
(HasCurCfg s fs, MonadState s m, All HTraversable fs,
 All HFunctor fs, All HFoldable fs) =>
m (EnterExitPair fs i)
-> EnterExitPair fs j -> m (EnterExitPair fs k)
`mCombineEnterExit` EnterExitPair gs k
body

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EnterExitPair gs Any -> Bool
forall (fs :: [(* -> *) -> * -> *]) i. EnterExitPair fs i -> Bool
eeNonEmpty EnterExitPair gs Any
cond) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair gs Any -> CfgNode gs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair gs Any
cond) CfgNode gs
exitNode

  EnterExitPair gs l -> m (EnterExitPair gs l)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs l -> m (EnterExitPair gs l))
-> EnterExitPair gs l -> m (EnterExitPair gs l)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs l
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode



constructCfgBreak :: (HasLoopStack s, MonadState s m, CfgComponent gs s) => TermLab gs l -> m (EnterExitPair gs i)
constructCfgBreak :: TermLab gs l -> m (EnterExitPair gs i)
constructCfgBreak t :: TermLab gs l
t = do
  CfgNode gs
enterNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
EnterNode
  CfgNode gs
exitNode  <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode

  [Label]
l' <- Getting [Label] s [Label] -> m [Label]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [Label] s [Label]
forall c. HasLoopStack c => Lens' c [Label]
break_stack
  let (l :: Label
l:_) = [Label]
l'
  Maybe (CfgNode gs)
n' <- Label -> m (Maybe (CfgNode gs))
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *).
(HasCurCfg s fs, MonadState s m) =>
Label -> m (Maybe (CfgNode fs))
nodeForLab Label
l
  let Just n :: CfgNode gs
n = Maybe (CfgNode gs)
n'
  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
enterNode CfgNode gs
n -- go to end of loop
  -- do not connect enter to exit

  EnterExitPair gs i -> m (EnterExitPair gs i)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs i -> m (EnterExitPair gs i))
-> EnterExitPair gs i -> m (EnterExitPair gs i)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs i
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode

constructCfgContinue :: (HasLoopStack s, MonadState s m, CfgComponent gs s) => TermLab gs l -> m (EnterExitPair gs i)
constructCfgContinue :: TermLab gs l -> m (EnterExitPair gs i)
constructCfgContinue t :: TermLab gs l
t = do
  CfgNode gs
enterNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
EnterNode
  CfgNode gs
exitNode  <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode
  [Label]
l' <- Getting [Label] s [Label] -> m [Label]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting [Label] s [Label]
forall c. HasLoopStack c => Lens' c [Label]
continue_stack
  let (l :: Label
l:_) = [Label]
l'
  Maybe (CfgNode gs)
n' <- Label -> m (Maybe (CfgNode gs))
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *).
(HasCurCfg s fs, MonadState s m) =>
Label -> m (Maybe (CfgNode fs))
nodeForLab Label
l
  let Just n :: CfgNode gs
n = Maybe (CfgNode gs)
n'
  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
enterNode CfgNode gs
n -- go to beginning of loop
  -- do not connect enter to exit

  EnterExitPair gs i -> m (EnterExitPair gs i)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs i -> m (EnterExitPair gs i))
-> EnterExitPair gs i -> m (EnterExitPair gs i)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs i
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode

-- For goto label nodes, we create a label for the node the first time it's referenced,
-- and accumulate a list of nodes that want to connect to it. When it's added for real, we clear this
--
-- "Label" can refer to both the annotation on nodes, and the program construct used as a goto target.
-- This is confusing.
data LabelMap = LabelMap {
                           LabelMap -> Map [Char] (Label, [Label])
_label_map :: Map String (Label, [Label])
                         }
  deriving ( LabelMap -> LabelMap -> Bool
(LabelMap -> LabelMap -> Bool)
-> (LabelMap -> LabelMap -> Bool) -> Eq LabelMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LabelMap -> LabelMap -> Bool
$c/= :: LabelMap -> LabelMap -> Bool
== :: LabelMap -> LabelMap -> Bool
$c== :: LabelMap -> LabelMap -> Bool
Eq, Eq LabelMap
Eq LabelMap =>
(LabelMap -> LabelMap -> Ordering)
-> (LabelMap -> LabelMap -> Bool)
-> (LabelMap -> LabelMap -> Bool)
-> (LabelMap -> LabelMap -> Bool)
-> (LabelMap -> LabelMap -> Bool)
-> (LabelMap -> LabelMap -> LabelMap)
-> (LabelMap -> LabelMap -> LabelMap)
-> Ord LabelMap
LabelMap -> LabelMap -> Bool
LabelMap -> LabelMap -> Ordering
LabelMap -> LabelMap -> LabelMap
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 :: LabelMap -> LabelMap -> LabelMap
$cmin :: LabelMap -> LabelMap -> LabelMap
max :: LabelMap -> LabelMap -> LabelMap
$cmax :: LabelMap -> LabelMap -> LabelMap
>= :: LabelMap -> LabelMap -> Bool
$c>= :: LabelMap -> LabelMap -> Bool
> :: LabelMap -> LabelMap -> Bool
$c> :: LabelMap -> LabelMap -> Bool
<= :: LabelMap -> LabelMap -> Bool
$c<= :: LabelMap -> LabelMap -> Bool
< :: LabelMap -> LabelMap -> Bool
$c< :: LabelMap -> LabelMap -> Bool
compare :: LabelMap -> LabelMap -> Ordering
$ccompare :: LabelMap -> LabelMap -> Ordering
$cp1Ord :: Eq LabelMap
Ord, Int -> LabelMap -> ShowS
[LabelMap] -> ShowS
LabelMap -> [Char]
(Int -> LabelMap -> ShowS)
-> (LabelMap -> [Char]) -> ([LabelMap] -> ShowS) -> Show LabelMap
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LabelMap] -> ShowS
$cshowList :: [LabelMap] -> ShowS
show :: LabelMap -> [Char]
$cshow :: LabelMap -> [Char]
showsPrec :: Int -> LabelMap -> ShowS
$cshowsPrec :: Int -> LabelMap -> ShowS
Show )

emptyLabelMap :: LabelMap
emptyLabelMap :: LabelMap
emptyLabelMap = Map [Char] (Label, [Label]) -> LabelMap
LabelMap Map [Char] (Label, [Label])
forall k a. Map k a
Map.empty

makeClassy ''LabelMap

speculativeGetLabel :: (MonadState s m, HasLabelMap s, HasLabelGen s) => String -> m Label
speculativeGetLabel :: [Char] -> m Label
speculativeGetLabel s :: [Char]
s = do
  Map [Char] (Label, [Label])
lm <- Getting
  (Map [Char] (Label, [Label])) s (Map [Char] (Label, [Label]))
-> m (Map [Char] (Label, [Label]))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map [Char] (Label, [Label])) s (Map [Char] (Label, [Label]))
forall c. HasLabelMap c => Lens' c (Map [Char] (Label, [Label]))
label_map
  case [Char] -> Map [Char] (Label, [Label]) -> Maybe (Label, [Label])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
s Map [Char] (Label, [Label])
lm of
    Just (lab :: Label
lab, _) -> Label -> m Label
forall (m :: * -> *) a. Monad m => a -> m a
return Label
lab
    Nothing -> do
      Label
lab <- m Label
forall s (m :: * -> *). MonadLabeler s m => m Label
nextLabel
      (Map [Char] (Label, [Label])
 -> Identity (Map [Char] (Label, [Label])))
-> s -> Identity s
forall c. HasLabelMap c => Lens' c (Map [Char] (Label, [Label]))
label_map ((Map [Char] (Label, [Label])
  -> Identity (Map [Char] (Label, [Label])))
 -> s -> Identity s)
-> (Map [Char] (Label, [Label]) -> Map [Char] (Label, [Label]))
-> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= [Char]
-> (Label, [Label])
-> Map [Char] (Label, [Label])
-> Map [Char] (Label, [Label])
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
s (Label
lab, [])
      Label -> m Label
forall (m :: * -> *) a. Monad m => a -> m a
return Label
lab

addGotoEdge :: (MonadState s m, HasLabelMap s, CfgComponent gs s) => CfgNode gs -> String -> m ()
addGotoEdge :: CfgNode gs -> [Char] -> m ()
addGotoEdge n :: CfgNode gs
n targName :: [Char]
targName = do
  Label
targL <- [Char] -> m Label
forall s (m :: * -> *).
(MonadState s m, HasLabelMap s, HasLabelGen s) =>
[Char] -> m Label
speculativeGetLabel [Char]
targName
  Maybe (CfgNode gs)
targNode <- Label -> m (Maybe (CfgNode gs))
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *).
(HasCurCfg s fs, MonadState s m) =>
Label -> m (Maybe (CfgNode fs))
nodeForLab Label
targL
  case Maybe (CfgNode gs)
targNode of
    Just n' :: CfgNode gs
n' -> (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
n CfgNode gs
n'
    Nothing -> (Map [Char] (Label, [Label])
 -> Identity (Map [Char] (Label, [Label])))
-> s -> Identity s
forall c. HasLabelMap c => Lens' c (Map [Char] (Label, [Label]))
label_map ((Map [Char] (Label, [Label])
  -> Identity (Map [Char] (Label, [Label])))
 -> s -> Identity s)
-> ((Maybe (Label, [Label]) -> Identity (Maybe (Label, [Label])))
    -> Map [Char] (Label, [Label])
    -> Identity (Map [Char] (Label, [Label])))
-> (Maybe (Label, [Label]) -> Identity (Maybe (Label, [Label])))
-> s
-> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map [Char] (Label, [Label]))
-> Lens'
     (Map [Char] (Label, [Label]))
     (Maybe (IxValue (Map [Char] (Label, [Label]))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at [Char]
Index (Map [Char] (Label, [Label]))
targName ((Maybe (Label, [Label]) -> Identity (Maybe (Label, [Label])))
 -> s -> Identity s)
-> (Maybe (Label, [Label]) -> Maybe (Label, [Label])) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ((Label, [Label]) -> (Label, [Label]))
-> Maybe (Label, [Label]) -> Maybe (Label, [Label])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Label] -> Identity [Label])
-> (Label, [Label]) -> Identity (Label, [Label])
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([Label] -> Identity [Label])
 -> (Label, [Label]) -> Identity (Label, [Label]))
-> ([Label] -> [Label]) -> (Label, [Label]) -> (Label, [Label])
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((CfgNode gs
n CfgNode gs -> Getting Label (CfgNode gs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode gs) Label
forall c (fs :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab)Label -> [Label] -> [Label]
forall a. a -> [a] -> [a]
:))

constructCfgGoto :: (MonadState s m, HasLabelMap s, CfgComponent gs s) => TermLab gs l -> String -> m (EnterExitPair gs i)
constructCfgGoto :: TermLab gs l -> [Char] -> m (EnterExitPair gs i)
constructCfgGoto t :: TermLab gs l
t targ :: [Char]
targ = do
  CfgNode gs
enterNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
EnterNode
  CfgNode gs
exitNode  <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode

  CfgNode gs -> [Char] -> m ()
forall s (m :: * -> *) (gs :: [(* -> *) -> * -> *]).
(MonadState s m, HasLabelMap s, CfgComponent gs s) =>
CfgNode gs -> [Char] -> m ()
addGotoEdge CfgNode gs
enterNode [Char]
targ
  -- do not connect enter to exit

  EnterExitPair gs i -> m (EnterExitPair gs i)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs i -> m (EnterExitPair gs i))
-> EnterExitPair gs i -> m (EnterExitPair gs i)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs i
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode

constructCfgLabel :: forall gs s m l i. (MonadState s m, HasLabelMap s, CfgComponent gs s) => TermLab gs l -> String -> m (EnterExitPair gs i)
constructCfgLabel :: TermLab gs l -> [Char] -> m (EnterExitPair gs i)
constructCfgLabel t :: TermLab gs l
t name :: [Char]
name = do
  Map [Char] (Label, [Label])
lm <- Getting
  (Map [Char] (Label, [Label])) s (Map [Char] (Label, [Label]))
-> m (Map [Char] (Label, [Label]))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map [Char] (Label, [Label])) s (Map [Char] (Label, [Label]))
forall c. HasLabelMap c => Lens' c (Map [Char] (Label, [Label]))
label_map

  CfgNode gs
enterNode <- case [Char] -> Map [Char] (Label, [Label]) -> Maybe (Label, [Label])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
name Map [Char] (Label, [Label])
lm of
    Nothing -> do
      Label
l <- m Label
forall s (m :: * -> *). MonadLabeler s m => m Label
nextLabel
      CfgNode gs
n <- TermLab gs l -> Label -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, MonadState s m) =>
TermLab fs l -> Label -> CfgNodeType -> m (CfgNode fs)
addCfgNodeWithLabel TermLab gs l
t Label
l CfgNodeType
EnterNode
      (Map [Char] (Label, [Label])
 -> Identity (Map [Char] (Label, [Label])))
-> s -> Identity s
forall c. HasLabelMap c => Lens' c (Map [Char] (Label, [Label]))
label_map ((Map [Char] (Label, [Label])
  -> Identity (Map [Char] (Label, [Label])))
 -> s -> Identity s)
-> (Map [Char] (Label, [Label]) -> Map [Char] (Label, [Label]))
-> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= [Char]
-> (Label, [Label])
-> Map [Char] (Label, [Label])
-> Map [Char] (Label, [Label])
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
name (Label
l, [])
      CfgNode gs -> m (CfgNode gs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CfgNode gs
n

    Just (l :: Label
l, prevs :: [Label]
prevs) -> do
      CfgNode gs
n <- TermLab gs l -> Label -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, MonadState s m) =>
TermLab fs l -> Label -> CfgNodeType -> m (CfgNode fs)
addCfgNodeWithLabel TermLab gs l
t Label
l CfgNodeType
EnterNode
      [Label] -> (Label -> m ()) -> m [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Label]
prevs ((Label -> m ()) -> m [()]) -> (Label -> m ()) -> m [()]
forall a b. (a -> b) -> a -> b
$ \p :: Label
p -> (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Proxy gs -> Label -> Label -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
Proxy fs -> Label -> Label -> Cfg fs -> Cfg fs
addEdgeLab (Proxy gs
forall k (t :: k). Proxy t
Proxy :: Proxy gs) Label
p Label
l
      (Map [Char] (Label, [Label])
 -> Identity (Map [Char] (Label, [Label])))
-> s -> Identity s
forall c. HasLabelMap c => Lens' c (Map [Char] (Label, [Label]))
label_map ((Map [Char] (Label, [Label])
  -> Identity (Map [Char] (Label, [Label])))
 -> s -> Identity s)
-> ((Maybe (Label, [Label]) -> Identity (Maybe (Label, [Label])))
    -> Map [Char] (Label, [Label])
    -> Identity (Map [Char] (Label, [Label])))
-> (Maybe (Label, [Label]) -> Identity (Maybe (Label, [Label])))
-> s
-> Identity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map [Char] (Label, [Label]))
-> Lens'
     (Map [Char] (Label, [Label]))
     (Maybe (IxValue (Map [Char] (Label, [Label]))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at [Char]
Index (Map [Char] (Label, [Label]))
name ((Maybe (Label, [Label]) -> Identity (Maybe (Label, [Label])))
 -> s -> Identity s)
-> (Maybe (Label, [Label]) -> Maybe (Label, [Label])) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ((Label, [Label]) -> (Label, [Label]))
-> Maybe (Label, [Label]) -> Maybe (Label, [Label])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Label] -> Identity [Label])
-> (Label, [Label]) -> Identity (Label, [Label])
forall s t a b. Field2 s t a b => Lens s t a b
_2 (([Label] -> Identity [Label])
 -> (Label, [Label]) -> Identity (Label, [Label]))
-> [Label] -> (Label, [Label]) -> (Label, [Label])
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [])
      CfgNode gs -> m (CfgNode gs)
forall (m :: * -> *) a. Monad m => a -> m a
return CfgNode gs
n


  CfgNode gs
exitNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode

  (Cfg gs -> Identity (Cfg gs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg gs -> Identity (Cfg gs)) -> s -> Identity s)
-> (Cfg gs -> Cfg gs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode gs -> CfgNode gs -> Cfg gs -> Cfg gs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode gs
enterNode CfgNode gs
exitNode
  EnterExitPair gs i -> m (EnterExitPair gs i)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs i -> m (EnterExitPair gs i))
-> EnterExitPair gs i -> m (EnterExitPair gs i)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs i
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode

-- |
-- Use this if labels are lexically scoped and may not be shadowed
-- In accordance with the representable/valid principle, we are not reusing LabelMap
-- for this purpose. LabelMap is for C's goto labels; ScopedLabelMap is for Java/JS labeled break/continue
data ScopedLabelMap = ScopedLabelMap {
                           ScopedLabelMap -> Map [Char] (Map CfgNodeType Label)
_scoped_label_map :: Map String (Map CfgNodeType Label)
                         }
  deriving ( ScopedLabelMap -> ScopedLabelMap -> Bool
(ScopedLabelMap -> ScopedLabelMap -> Bool)
-> (ScopedLabelMap -> ScopedLabelMap -> Bool) -> Eq ScopedLabelMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScopedLabelMap -> ScopedLabelMap -> Bool
$c/= :: ScopedLabelMap -> ScopedLabelMap -> Bool
== :: ScopedLabelMap -> ScopedLabelMap -> Bool
$c== :: ScopedLabelMap -> ScopedLabelMap -> Bool
Eq, Eq ScopedLabelMap
Eq ScopedLabelMap =>
(ScopedLabelMap -> ScopedLabelMap -> Ordering)
-> (ScopedLabelMap -> ScopedLabelMap -> Bool)
-> (ScopedLabelMap -> ScopedLabelMap -> Bool)
-> (ScopedLabelMap -> ScopedLabelMap -> Bool)
-> (ScopedLabelMap -> ScopedLabelMap -> Bool)
-> (ScopedLabelMap -> ScopedLabelMap -> ScopedLabelMap)
-> (ScopedLabelMap -> ScopedLabelMap -> ScopedLabelMap)
-> Ord ScopedLabelMap
ScopedLabelMap -> ScopedLabelMap -> Bool
ScopedLabelMap -> ScopedLabelMap -> Ordering
ScopedLabelMap -> ScopedLabelMap -> ScopedLabelMap
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 :: ScopedLabelMap -> ScopedLabelMap -> ScopedLabelMap
$cmin :: ScopedLabelMap -> ScopedLabelMap -> ScopedLabelMap
max :: ScopedLabelMap -> ScopedLabelMap -> ScopedLabelMap
$cmax :: ScopedLabelMap -> ScopedLabelMap -> ScopedLabelMap
>= :: ScopedLabelMap -> ScopedLabelMap -> Bool
$c>= :: ScopedLabelMap -> ScopedLabelMap -> Bool
> :: ScopedLabelMap -> ScopedLabelMap -> Bool
$c> :: ScopedLabelMap -> ScopedLabelMap -> Bool
<= :: ScopedLabelMap -> ScopedLabelMap -> Bool
$c<= :: ScopedLabelMap -> ScopedLabelMap -> Bool
< :: ScopedLabelMap -> ScopedLabelMap -> Bool
$c< :: ScopedLabelMap -> ScopedLabelMap -> Bool
compare :: ScopedLabelMap -> ScopedLabelMap -> Ordering
$ccompare :: ScopedLabelMap -> ScopedLabelMap -> Ordering
$cp1Ord :: Eq ScopedLabelMap
Ord, Int -> ScopedLabelMap -> ShowS
[ScopedLabelMap] -> ShowS
ScopedLabelMap -> [Char]
(Int -> ScopedLabelMap -> ShowS)
-> (ScopedLabelMap -> [Char])
-> ([ScopedLabelMap] -> ShowS)
-> Show ScopedLabelMap
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ScopedLabelMap] -> ShowS
$cshowList :: [ScopedLabelMap] -> ShowS
show :: ScopedLabelMap -> [Char]
$cshow :: ScopedLabelMap -> [Char]
showsPrec :: Int -> ScopedLabelMap -> ShowS
$cshowsPrec :: Int -> ScopedLabelMap -> ShowS
Show )

emptyScopedLabelMap :: ScopedLabelMap
emptyScopedLabelMap :: ScopedLabelMap
emptyScopedLabelMap = Map [Char] (Map CfgNodeType Label) -> ScopedLabelMap
ScopedLabelMap Map [Char] (Map CfgNodeType Label)
forall k a. Map k a
Map.empty

makeClassy ''ScopedLabelMap

withScopedLabel :: (MonadState s m, HasScopedLabelMap s) => String -> Map CfgNodeType Label -> m a -> m a
withScopedLabel :: [Char] -> Map CfgNodeType Label -> m a -> m a
withScopedLabel s :: [Char]
s labMap :: Map CfgNodeType Label
labMap m :: m a
m = do
  Map [Char] (Map CfgNodeType Label)
oldLabMap <- Getting
  (Map [Char] (Map CfgNodeType Label))
  s
  (Map [Char] (Map CfgNodeType Label))
-> m (Map [Char] (Map CfgNodeType Label))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map [Char] (Map CfgNodeType Label))
  s
  (Map [Char] (Map CfgNodeType Label))
forall c.
HasScopedLabelMap c =>
Lens' c (Map [Char] (Map CfgNodeType Label))
scoped_label_map
  (Map [Char] (Map CfgNodeType Label)
 -> Identity (Map [Char] (Map CfgNodeType Label)))
-> s -> Identity s
forall c.
HasScopedLabelMap c =>
Lens' c (Map [Char] (Map CfgNodeType Label))
scoped_label_map ((Map [Char] (Map CfgNodeType Label)
  -> Identity (Map [Char] (Map CfgNodeType Label)))
 -> s -> Identity s)
-> (Map [Char] (Map CfgNodeType Label)
    -> Map [Char] (Map CfgNodeType Label))
-> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= [Char]
-> Map CfgNodeType Label
-> Map [Char] (Map CfgNodeType Label)
-> Map [Char] (Map CfgNodeType Label)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
s Map CfgNodeType Label
labMap
  a
res <- m a
m
  (Map [Char] (Map CfgNodeType Label)
 -> Identity (Map [Char] (Map CfgNodeType Label)))
-> s -> Identity s
forall c.
HasScopedLabelMap c =>
Lens' c (Map [Char] (Map CfgNodeType Label))
scoped_label_map ((Map [Char] (Map CfgNodeType Label)
  -> Identity (Map [Char] (Map CfgNodeType Label)))
 -> s -> Identity s)
-> Map [Char] (Map CfgNodeType Label) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Map [Char] (Map CfgNodeType Label)
oldLabMap
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res


nodeForScopedLabel :: (MonadState s m, HasScopedLabelMap s, CfgComponent fs s) => String -> CfgNodeType -> m (Maybe (CfgNode fs))
nodeForScopedLabel :: [Char] -> CfgNodeType -> m (Maybe (CfgNode fs))
nodeForScopedLabel nm :: [Char]
nm tp :: CfgNodeType
tp = do
  Map [Char] (Map CfgNodeType Label)
slm <- Getting
  (Map [Char] (Map CfgNodeType Label))
  s
  (Map [Char] (Map CfgNodeType Label))
-> m (Map [Char] (Map CfgNodeType Label))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map [Char] (Map CfgNodeType Label))
  s
  (Map [Char] (Map CfgNodeType Label))
forall c.
HasScopedLabelMap c =>
Lens' c (Map [Char] (Map CfgNodeType Label))
scoped_label_map
  Cfg fs
gr <- Getting (Cfg fs) s (Cfg fs) -> m (Cfg fs)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Cfg fs) s (Cfg fs)
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg
  Maybe (CfgNode fs) -> m (Maybe (CfgNode fs))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
-> Map [Char] (Map CfgNodeType Label)
-> Maybe (Map CfgNodeType Label)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
nm Map [Char] (Map CfgNodeType Label)
slm Maybe (Map CfgNodeType Label)
-> (Map CfgNodeType Label -> Maybe Label) -> Maybe Label
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CfgNodeType -> Map CfgNodeType Label -> Maybe Label
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CfgNodeType
tp Maybe Label -> (Label -> Maybe (CfgNode fs)) -> Maybe (CfgNode fs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cfg fs -> Label -> Maybe (CfgNode fs)
forall (fs :: [(* -> *) -> * -> *]).
Cfg fs -> Label -> Maybe (CfgNode fs)
safeLookupCfg Cfg fs
gr)

edgeToScopedLabel :: (MonadState s m, HasScopedLabelMap s, CfgComponent fs s) => CfgNode fs -> String -> CfgNodeType -> m ()
edgeToScopedLabel :: CfgNode fs -> [Char] -> CfgNodeType -> m ()
edgeToScopedLabel n :: CfgNode fs
n targName :: [Char]
targName targTp :: CfgNodeType
targTp = do
  Maybe (CfgNode fs)
targNode <- [Char] -> CfgNodeType -> m (Maybe (CfgNode fs))
forall s (m :: * -> *) (fs :: [(* -> *) -> * -> *]).
(MonadState s m, HasScopedLabelMap s, CfgComponent fs s) =>
[Char] -> CfgNodeType -> m (Maybe (CfgNode fs))
nodeForScopedLabel [Char]
targName CfgNodeType
targTp
  case Maybe (CfgNode fs)
targNode of
    Nothing -> [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ "Label " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
targName [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ " has no node of type " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ CfgNodeType -> [Char]
forall a. Show a => a -> [Char]
show CfgNodeType
targTp
    Just n' :: CfgNode fs
n' -> (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode fs
n CfgNode fs
n'



constructCfgScopedLabeledBreak :: (HasScopedLabelMap s, MonadState s m, CfgComponent gs s) => TermLab gs l -> String -> m (EnterExitPair gs i)
constructCfgScopedLabeledBreak :: TermLab gs l -> [Char] -> m (EnterExitPair gs i)
constructCfgScopedLabeledBreak t :: TermLab gs l
t labStr :: [Char]
labStr = do
  CfgNode gs
enterNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
EnterNode
  CfgNode gs
exitNode  <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode

  CfgNode gs -> [Char] -> CfgNodeType -> m ()
forall s (m :: * -> *) (fs :: [(* -> *) -> * -> *]).
(MonadState s m, HasScopedLabelMap s, CfgComponent fs s) =>
CfgNode fs -> [Char] -> CfgNodeType -> m ()
edgeToScopedLabel CfgNode gs
enterNode [Char]
labStr CfgNodeType
ExitNode
  -- do not connect enter to exit

  EnterExitPair gs i -> m (EnterExitPair gs i)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs i -> m (EnterExitPair gs i))
-> EnterExitPair gs i -> m (EnterExitPair gs i)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs i
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode


constructCfgScopedLabeledContinue :: (HasScopedLabelMap s, MonadState s m, CfgComponent gs s) => TermLab gs l -> String -> m (EnterExitPair gs i)
constructCfgScopedLabeledContinue :: TermLab gs l -> [Char] -> m (EnterExitPair gs i)
constructCfgScopedLabeledContinue t :: TermLab gs l
t labStr :: [Char]
labStr = do
  CfgNode gs
enterNode <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
EnterNode
  CfgNode gs
exitNode  <- TermLab gs l -> CfgNodeType -> m (CfgNode gs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab gs l
t CfgNodeType
ExitNode

  CfgNode gs -> [Char] -> CfgNodeType -> m ()
forall s (m :: * -> *) (fs :: [(* -> *) -> * -> *]).
(MonadState s m, HasScopedLabelMap s, CfgComponent fs s) =>
CfgNode fs -> [Char] -> CfgNodeType -> m ()
edgeToScopedLabel CfgNode gs
enterNode [Char]
labStr CfgNodeType
LoopEntryNode
  -- do not connect enter to exit

  EnterExitPair gs i -> m (EnterExitPair gs i)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnterExitPair gs i -> m (EnterExitPair gs i))
-> EnterExitPair gs i -> m (EnterExitPair gs i)
forall a b. (a -> b) -> a -> b
$ CfgNode gs -> CfgNode gs -> EnterExitPair gs i
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode gs
enterNode CfgNode gs
exitNode

constructCfgScopedLabel ::
  ( HasScopedLabelMap s
  , MonadState s m
  , CfgComponent fs s
  ) => TermLab fs l -> String -> TermLab fs s0 -> m (EnterExitPair fs s0) -> m (EnterExitPair fs i)
constructCfgScopedLabel :: TermLab fs l
-> [Char]
-> TermLab fs s0
-> m (EnterExitPair fs s0)
-> m (EnterExitPair fs i)
constructCfgScopedLabel t :: TermLab fs l
t labName :: [Char]
labName s :: TermLab fs s0
s mStmt :: m (EnterExitPair fs s0)
mStmt = do
  CfgNode fs
enterNode     <- TermLab fs l -> CfgNodeType -> m (CfgNode fs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab fs l
t CfgNodeType
EnterNode
  CfgNode fs
loopEntryNode <- TermLab fs l -> CfgNodeType -> m (CfgNode fs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab fs l
t CfgNodeType
LoopEntryNode
  CfgNode fs
exitNode      <- TermLab fs l -> CfgNodeType -> m (CfgNode fs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab fs l
t CfgNodeType
ExitNode

  -- Using a label as a continue target is not valid unless the labeled statement is a loop
  -- We assume that this code is valid JS / Java, and hence loopEntryNode is unused unless
  -- stmt is a loop
  let labMap :: Map CfgNodeType Label
labMap = [(CfgNodeType, Label)] -> Map CfgNodeType Label
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (CfgNodeType
LoopEntryNode, CfgNode fs
loopEntryNode CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab)
                            , (CfgNodeType
ExitNode, CfgNode fs
exitNode CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab)
                            ]

  EnterExitPair fs s0
stmt <- [Char]
-> Map CfgNodeType Label
-> m (EnterExitPair fs s0)
-> m (EnterExitPair fs s0)
forall s (m :: * -> *) a.
(MonadState s m, HasScopedLabelMap s) =>
[Char] -> Map CfgNodeType Label -> m a -> m a
withScopedLabel [Char]
labName Map CfgNodeType Label
labMap m (EnterExitPair fs s0)
mStmt
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode fs
enterNode (EnterExitPair fs s0 -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair fs s0
stmt)
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair fs s0 -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair fs s0
stmt) CfgNode fs
exitNode

  -- loopEntryNode is just a temporary; contract it out
  Cfg fs
gr <- Getting (Cfg fs) s (Cfg fs) -> m (Cfg fs)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Cfg fs) s (Cfg fs)
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg
  case Cfg fs -> CfgNodeType -> TermLab fs s0 -> Maybe (CfgNode fs)
forall (fs :: [(* -> *) -> * -> *]) l.
Cfg fs -> CfgNodeType -> TermLab fs l -> Maybe (CfgNode fs)
cfgNodeForTerm Cfg fs
gr CfgNodeType
LoopEntryNode TermLab fs s0
s of
    Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just n :: CfgNode fs
n  -> (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode fs
loopEntryNode CfgNode fs
n

  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Label -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]). Label -> Cfg fs -> Cfg fs
contractNode (CfgNode fs
loopEntryNode CfgNode fs -> Getting Label (CfgNode fs) Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label (CfgNode fs) Label
forall c (fs :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c Label
cfg_node_lab)

  EnterExitPair fs i -> m (EnterExitPair fs i)
forall (m :: * -> *) a. Monad m => a -> m a
return (CfgNode fs -> CfgNode fs -> EnterExitPair fs i
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode fs
enterNode CfgNode fs
exitNode)

constructCfgShortCircuitingBinOp ::
  ( MonadState s m
  , CfgComponent fs s
  ) => TermLab fs l -> m (EnterExitPair fs ls) -> m (EnterExitPair fs rs) -> m (EnterExitPair fs es)
constructCfgShortCircuitingBinOp :: TermLab fs l
-> m (EnterExitPair fs ls)
-> m (EnterExitPair fs rs)
-> m (EnterExitPair fs es)
constructCfgShortCircuitingBinOp t :: TermLab fs l
t mlArg :: m (EnterExitPair fs ls)
mlArg mrArg :: m (EnterExitPair fs rs)
mrArg = do
  CfgNode fs
enterNode <- TermLab fs l -> CfgNodeType -> m (CfgNode fs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab fs l
t CfgNodeType
EnterNode
  CfgNode fs
exitNode  <- TermLab fs l -> CfgNodeType -> m (CfgNode fs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab fs l
t CfgNodeType
ExitNode
  EnterExitPair fs ls
lArg <- m (EnterExitPair fs ls)
mlArg
  EnterExitPair fs rs
rArg <- m (EnterExitPair fs rs)
mrArg
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode fs
enterNode (EnterExitPair fs ls -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair fs ls
lArg)
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair fs ls -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair fs ls
lArg) (EnterExitPair fs rs -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair fs rs
rArg)
  -- NOTE: short circuit edge.
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair fs ls -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair fs ls
lArg) CfgNode fs
exitNode
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair fs rs -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair fs rs
rArg) CfgNode fs
exitNode
  EnterExitPair fs es -> m (EnterExitPair fs es)
forall (m :: * -> *) a. Monad m => a -> m a
return (CfgNode fs -> CfgNode fs -> EnterExitPair fs es
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode fs
enterNode CfgNode fs
exitNode)

constructCfgCondOp ::
  ( MonadState s m
  , CfgComponent fs s
  ) => TermLab fs l -> m (EnterExitPair fs ls) -> m (EnterExitPair fs rs) -> m (EnterExitPair fs es) -> m (EnterExitPair fs es)
constructCfgCondOp :: TermLab fs l
-> m (EnterExitPair fs ls)
-> m (EnterExitPair fs rs)
-> m (EnterExitPair fs es)
-> m (EnterExitPair fs es)
constructCfgCondOp t :: TermLab fs l
t mtest :: m (EnterExitPair fs ls)
mtest msucc :: m (EnterExitPair fs rs)
msucc mfail :: m (EnterExitPair fs es)
mfail = do
  CfgNode fs
enterNode <- TermLab fs l -> CfgNodeType -> m (CfgNode fs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab fs l
t CfgNodeType
EnterNode
  CfgNode fs
exitNode  <- TermLab fs l -> CfgNodeType -> m (CfgNode fs)
forall s (fs :: [(* -> *) -> * -> *]) (m :: * -> *) l.
(HasCurCfg s fs, HasLabelGen s, MonadState s m) =>
TermLab fs l -> CfgNodeType -> m (CfgNode fs)
addCfgNode TermLab fs l
t CfgNodeType
ExitNode
  EnterExitPair fs ls
test <- m (EnterExitPair fs ls)
mtest
  EnterExitPair fs rs
succ <- m (EnterExitPair fs rs)
msucc
  EnterExitPair fs es
fail <- m (EnterExitPair fs es)
mfail
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge CfgNode fs
enterNode (EnterExitPair fs ls -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair fs ls
test)
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair fs ls -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair fs ls
test) (EnterExitPair fs rs -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair fs rs
succ)
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair fs ls -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair fs ls
test) (EnterExitPair fs es -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
enter EnterExitPair fs es
fail)
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair fs rs -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair fs rs
succ) CfgNode fs
exitNode
  (Cfg fs -> Identity (Cfg fs)) -> s -> Identity s
forall c (fs :: [(* -> *) -> * -> *]).
HasCurCfg c fs =>
Lens' c (Cfg fs)
cur_cfg ((Cfg fs -> Identity (Cfg fs)) -> s -> Identity s)
-> (Cfg fs -> Cfg fs) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]).
CfgNode fs -> CfgNode fs -> Cfg fs -> Cfg fs
addEdge (EnterExitPair fs es -> CfgNode fs
forall (fs :: [(* -> *) -> * -> *]) l.
EnterExitPair fs l -> CfgNode fs
exit EnterExitPair fs es
fail) CfgNode fs
exitNode
  EnterExitPair fs es -> m (EnterExitPair fs es)
forall (m :: * -> *) a. Monad m => a -> m a
return (CfgNode fs -> CfgNode fs -> EnterExitPair fs es
forall (fs :: [(* -> *) -> * -> *]) l.
CfgNode fs -> CfgNode fs -> EnterExitPair fs l
EnterExitPair CfgNode fs
enterNode CfgNode fs
exitNode)