{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
module Tokstyle.Cimple.Analysis.CFG
    ( Node (..)
    , NodeKind (..)
    , EdgeType (..)
    , Edge
    , CFG
    , fromFunction
    , getFuncName
    ) where

import           Control.Monad        (foldM_, forM)
import           Control.Monad.Reader
import           Control.Monad.State
import           Data.Fix             (Fix (..), unFix)
import           Data.Map.Strict      (Map)
import qualified Data.Map.Strict      as Map
import           Data.Text            (Text)
import           Language.Cimple      (Lexeme (..), NodeF (..))
import qualified Language.Cimple      as C

-- | A node in the Control Flow Graph.
data Node = Node Int NodeKind
    deriving (Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Node] -> ShowS
$cshowList :: [Node] -> ShowS
show :: Node -> String
$cshow :: Node -> String
showsPrec :: Int -> Node -> ShowS
$cshowsPrec :: Int -> Node -> ShowS
Show)

data NodeKind
    = EntryNode
    | ExitNode
    | StmtNode (C.Node (Lexeme Text))
    | BranchNode (C.Node (Lexeme Text))
    deriving (Int -> NodeKind -> ShowS
[NodeKind] -> ShowS
NodeKind -> String
(Int -> NodeKind -> ShowS)
-> (NodeKind -> String) -> ([NodeKind] -> ShowS) -> Show NodeKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeKind] -> ShowS
$cshowList :: [NodeKind] -> ShowS
show :: NodeKind -> String
$cshow :: NodeKind -> String
showsPrec :: Int -> NodeKind -> ShowS
$cshowsPrec :: Int -> NodeKind -> ShowS
Show)

instance Eq Node where
    (Node Int
a NodeKind
_) == :: Node -> Node -> Bool
== (Node Int
b NodeKind
_) = Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b

instance Ord Node where
    compare :: Node -> Node -> Ordering
compare (Node Int
a NodeKind
_) (Node Int
b NodeKind
_) = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
a Int
b

-- | The type of transition between nodes.
data EdgeType
    = Unconditional
    | TrueBranch
    | FalseBranch
    | CaseBranch (C.Node (Lexeme Text))
    | DefaultBranch
    deriving (Int -> EdgeType -> ShowS
[EdgeType] -> ShowS
EdgeType -> String
(Int -> EdgeType -> ShowS)
-> (EdgeType -> String) -> ([EdgeType] -> ShowS) -> Show EdgeType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeType] -> ShowS
$cshowList :: [EdgeType] -> ShowS
show :: EdgeType -> String
$cshow :: EdgeType -> String
showsPrec :: Int -> EdgeType -> ShowS
$cshowsPrec :: Int -> EdgeType -> ShowS
Show)

instance Eq EdgeType where
    EdgeType
Unconditional == :: EdgeType -> EdgeType -> Bool
== EdgeType
Unconditional = Bool
True
    EdgeType
TrueBranch == EdgeType
TrueBranch       = Bool
True
    EdgeType
FalseBranch == EdgeType
FalseBranch     = Bool
True
    EdgeType
DefaultBranch == EdgeType
DefaultBranch = Bool
True
    CaseBranch Node (Lexeme Text)
_ == CaseBranch Node (Lexeme Text)
_   = Bool
True
    EdgeType
_ == EdgeType
_                         = Bool
False

type Edge = (EdgeType, Node)
type CFG = Map Node [Edge]

data BuildEnv = BuildEnv
    { BuildEnv -> Maybe Node
envBreak    :: Maybe Node
    , BuildEnv -> Maybe Node
envContinue :: Maybe Node
    , BuildEnv -> Node
envReturn   :: Node
    , BuildEnv -> Map Text Node
envLabels   :: Map Text Node
    }

data BuildState = BuildState
    { BuildState -> Int
stateNextId :: Int
    , BuildState -> CFG
stateEdges  :: CFG
    }

type BuildM = ReaderT BuildEnv (State BuildState)

newNodeState :: NodeKind -> State BuildState Node
newNodeState :: NodeKind -> State BuildState Node
newNodeState NodeKind
nk = do
    Int
i <- (BuildState -> Int) -> StateT BuildState Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BuildState -> Int
stateNextId
    (BuildState -> BuildState) -> StateT BuildState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BuildState -> BuildState) -> StateT BuildState Identity ())
-> (BuildState -> BuildState) -> StateT BuildState Identity ()
forall a b. (a -> b) -> a -> b
$ \BuildState
s -> BuildState
s { stateNextId :: Int
stateNextId = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
    Node -> State BuildState Node
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> State BuildState Node) -> Node -> State BuildState Node
forall a b. (a -> b) -> a -> b
$ Int -> NodeKind -> Node
Node Int
i NodeKind
nk

newNode :: NodeKind -> BuildM Node
newNode :: NodeKind -> BuildM Node
newNode = State BuildState Node -> BuildM Node
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State BuildState Node -> BuildM Node)
-> (NodeKind -> State BuildState Node) -> NodeKind -> BuildM Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKind -> State BuildState Node
newNodeState

getFuncName :: C.Node (Lexeme Text) -> Maybe Text
getFuncName :: Node (Lexeme Text) -> Maybe Text
getFuncName (Fix (C.VarExpr (C.L AlexPosn
_ LexemeClass
_ Text
name)))               = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name
getFuncName (Fix (C.LiteralExpr LiteralType
C.ConstId (C.L AlexPosn
_ LexemeClass
_ Text
name))) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name
getFuncName (Fix (C.ParenExpr Node (Lexeme Text)
e))                          = Node (Lexeme Text) -> Maybe Text
getFuncName Node (Lexeme Text)
e
getFuncName Node (Lexeme Text)
_                                              = Maybe Text
forall a. Maybe a
Nothing

isTerminating :: C.Node (Lexeme Text) -> Bool
isTerminating :: Node (Lexeme Text) -> Bool
isTerminating (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
    C.Return Maybe (Node (Lexeme Text))
_ -> Bool
True
    NodeF (Lexeme Text) (Node (Lexeme Text))
C.Break    -> Bool
True
    NodeF (Lexeme Text) (Node (Lexeme Text))
C.Continue -> Bool
True
    C.Goto Lexeme Text
_   -> Bool
True
    C.ExprStmt Node (Lexeme Text)
e -> Node (Lexeme Text) -> Bool
isTerminating Node (Lexeme Text)
e
    C.FunctionCall Node (Lexeme Text)
f [Node (Lexeme Text)]
_ -> case Node (Lexeme Text) -> Maybe Text
getFuncName Node (Lexeme Text)
f of
        Just Text
"abort"        -> Bool
True
        Just Text
"exit"         -> Bool
True
        Just Text
"LOGGER_FATAL" -> Bool
True
        Maybe Text
_                   -> Bool
False
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Bool
False

addEdgeM :: Node -> EdgeType -> Node -> State BuildState ()
addEdgeM :: Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
from EdgeType
et Node
to = (BuildState -> BuildState) -> StateT BuildState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((BuildState -> BuildState) -> StateT BuildState Identity ())
-> (BuildState -> BuildState) -> StateT BuildState Identity ()
forall a b. (a -> b) -> a -> b
$ \BuildState
s ->
    BuildState
s { stateEdges :: CFG
stateEdges = ([(EdgeType, Node)] -> [(EdgeType, Node)] -> [(EdgeType, Node)])
-> Node -> [(EdgeType, Node)] -> CFG -> CFG
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [(EdgeType, Node)] -> [(EdgeType, Node)] -> [(EdgeType, Node)]
forall a. [a] -> [a] -> [a]
(++) Node
from [(EdgeType
et, Node
to)] (BuildState -> CFG
stateEdges BuildState
s) }

-- | Build a CFG from a function definition.
fromFunction :: C.Node (Lexeme Text) -> (Node, CFG)
fromFunction :: Node (Lexeme Text) -> (Node, CFG)
fromFunction (Fix (FunctionDefn Scope
_ Node (Lexeme Text)
_ Node (Lexeme Text)
body)) =
    let (Node
exitNode, BuildState
s0) = State BuildState Node -> BuildState -> (Node, BuildState)
forall s a. State s a -> s -> (a, s)
runState (NodeKind -> State BuildState Node
newNodeState NodeKind
ExitNode) (Int -> CFG -> BuildState
BuildState Int
0 CFG
forall k a. Map k a
Map.empty)
        (Node
entryNode, BuildState
s1) = State BuildState Node -> BuildState -> (Node, BuildState)
forall s a. State s a -> s -> (a, s)
runState (NodeKind -> State BuildState Node
newNodeState NodeKind
EntryNode) BuildState
s0
        (Map Text Node
labels, BuildState
s2) = State BuildState (Map Text Node)
-> BuildState -> (Map Text Node, BuildState)
forall s a. State s a -> s -> (a, s)
runState (StateT (Map Text Node) (State BuildState) ()
-> Map Text Node -> State BuildState (Map Text Node)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels Node (Lexeme Text)
body) Map Text Node
forall k a. Map k a
Map.empty) BuildState
s1
        env :: BuildEnv
env = Maybe Node -> Maybe Node -> Node -> Map Text Node -> BuildEnv
BuildEnv Maybe Node
forall a. Maybe a
Nothing Maybe Node
forall a. Maybe a
Nothing Node
exitNode Map Text Node
labels
        (Node
actualEntry, BuildState
s3) = State BuildState Node -> BuildState -> (Node, BuildState)
forall s a. State s a -> s -> (a, s)
runState (BuildM Node -> BuildEnv -> State BuildState Node
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Node (Lexeme Text) -> Node -> BuildM Node
buildStmt Node (Lexeme Text)
body Node
exitNode) BuildEnv
env) BuildState
s2
        (()
_, BuildState
s4) = StateT BuildState Identity () -> BuildState -> ((), BuildState)
forall s a. State s a -> s -> (a, s)
runState (Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
entryNode EdgeType
Unconditional Node
actualEntry) BuildState
s3
    in (Node
entryNode, BuildState -> CFG
stateEdges BuildState
s4)
fromFunction Node (Lexeme Text)
_ = (Int -> NodeKind -> Node
Node Int
0 NodeKind
ExitNode, CFG
forall k a. Map k a
Map.empty)

collectLabels :: C.Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels :: Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
    Label (L AlexPosn
_ LexemeClass
_ Text
name) Node (Lexeme Text)
body -> do
        Node
node' <- State BuildState Node
-> StateT (Map Text Node) (State BuildState) Node
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State BuildState Node
 -> StateT (Map Text Node) (State BuildState) Node)
-> State BuildState Node
-> StateT (Map Text Node) (State BuildState) Node
forall a b. (a -> b) -> a -> b
$ NodeKind -> State BuildState Node
newNodeState (Node (Lexeme Text) -> NodeKind
StmtNode (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node))
        (Map Text Node -> Map Text Node)
-> StateT (Map Text Node) (State BuildState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map Text Node -> Map Text Node)
 -> StateT (Map Text Node) (State BuildState) ())
-> (Map Text Node -> Map Text Node)
-> StateT (Map Text Node) (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Map Text Node -> Map Text Node
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Node
node'
        Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels Node (Lexeme Text)
body
    CompoundStmt [Node (Lexeme Text)]
stmts -> (Node (Lexeme Text)
 -> StateT (Map Text Node) (State BuildState) ())
-> [Node (Lexeme Text)]
-> StateT (Map Text Node) (State BuildState) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels [Node (Lexeme Text)]
stmts
    IfStmt Node (Lexeme Text)
_ Node (Lexeme Text)
t Maybe (Node (Lexeme Text))
e -> Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels Node (Lexeme Text)
t StateT (Map Text Node) (State BuildState) ()
-> StateT (Map Text Node) (State BuildState) ()
-> StateT (Map Text Node) (State BuildState) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT (Map Text Node) (State BuildState) ()
-> (Node (Lexeme Text)
    -> StateT (Map Text Node) (State BuildState) ())
-> Maybe (Node (Lexeme Text))
-> StateT (Map Text Node) (State BuildState) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StateT (Map Text Node) (State BuildState) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels Maybe (Node (Lexeme Text))
e
    WhileStmt Node (Lexeme Text)
_ Node (Lexeme Text)
body -> Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels Node (Lexeme Text)
body
    DoWhileStmt Node (Lexeme Text)
body Node (Lexeme Text)
_ -> Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels Node (Lexeme Text)
body
    ForStmt Node (Lexeme Text)
_ Node (Lexeme Text)
_ Node (Lexeme Text)
_ Node (Lexeme Text)
body -> Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels Node (Lexeme Text)
body
    SwitchStmt Node (Lexeme Text)
_ [Node (Lexeme Text)]
cases -> (Node (Lexeme Text)
 -> StateT (Map Text Node) (State BuildState) ())
-> [Node (Lexeme Text)]
-> StateT (Map Text Node) (State BuildState) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels [Node (Lexeme Text)]
cases
    PreprocIf Node (Lexeme Text)
_ [Node (Lexeme Text)]
stmts Node (Lexeme Text)
next -> (Node (Lexeme Text)
 -> StateT (Map Text Node) (State BuildState) ())
-> [Node (Lexeme Text)]
-> StateT (Map Text Node) (State BuildState) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels [Node (Lexeme Text)]
stmts StateT (Map Text Node) (State BuildState) ()
-> StateT (Map Text Node) (State BuildState) ()
-> StateT (Map Text Node) (State BuildState) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels Node (Lexeme Text)
next
    PreprocIfdef Lexeme Text
_ [Node (Lexeme Text)]
stmts Node (Lexeme Text)
next -> (Node (Lexeme Text)
 -> StateT (Map Text Node) (State BuildState) ())
-> [Node (Lexeme Text)]
-> StateT (Map Text Node) (State BuildState) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels [Node (Lexeme Text)]
stmts StateT (Map Text Node) (State BuildState) ()
-> StateT (Map Text Node) (State BuildState) ()
-> StateT (Map Text Node) (State BuildState) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels Node (Lexeme Text)
next
    PreprocIfndef Lexeme Text
_ [Node (Lexeme Text)]
stmts Node (Lexeme Text)
next -> (Node (Lexeme Text)
 -> StateT (Map Text Node) (State BuildState) ())
-> [Node (Lexeme Text)]
-> StateT (Map Text Node) (State BuildState) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels [Node (Lexeme Text)]
stmts StateT (Map Text Node) (State BuildState) ()
-> StateT (Map Text Node) (State BuildState) ()
-> StateT (Map Text Node) (State BuildState) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels Node (Lexeme Text)
next
    PreprocElif Node (Lexeme Text)
_ [Node (Lexeme Text)]
stmts Node (Lexeme Text)
next -> (Node (Lexeme Text)
 -> StateT (Map Text Node) (State BuildState) ())
-> [Node (Lexeme Text)]
-> StateT (Map Text Node) (State BuildState) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels [Node (Lexeme Text)]
stmts StateT (Map Text Node) (State BuildState) ()
-> StateT (Map Text Node) (State BuildState) ()
-> StateT (Map Text Node) (State BuildState) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels Node (Lexeme Text)
next
    PreprocElse [Node (Lexeme Text)]
stmts -> (Node (Lexeme Text)
 -> StateT (Map Text Node) (State BuildState) ())
-> [Node (Lexeme Text)]
-> StateT (Map Text Node) (State BuildState) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels [Node (Lexeme Text)]
stmts
    PreprocScopedDefine Node (Lexeme Text)
_ [Node (Lexeme Text)]
stmts Node (Lexeme Text)
_ -> (Node (Lexeme Text)
 -> StateT (Map Text Node) (State BuildState) ())
-> [Node (Lexeme Text)]
-> StateT (Map Text Node) (State BuildState) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Node (Lexeme Text) -> StateT (Map Text Node) (State BuildState) ()
collectLabels [Node (Lexeme Text)]
stmts
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> () -> StateT (Map Text Node) (State BuildState) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

buildStmt :: C.Node (Lexeme Text) -> Node -> BuildM Node
buildStmt :: Node (Lexeme Text) -> Node -> BuildM Node
buildStmt (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) Node
next = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
    CompoundStmt [Node (Lexeme Text)]
stmts -> [Node (Lexeme Text)] -> Node -> BuildM Node
buildStmts [Node (Lexeme Text)]
stmts Node
next

    IfStmt Node (Lexeme Text)
cond Node (Lexeme Text)
thenBranch Maybe (Node (Lexeme Text))
elseBranchM -> do
        Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
BranchNode Node (Lexeme Text)
cond)
        Node
tEntry <- Node (Lexeme Text) -> Node -> BuildM Node
buildStmt Node (Lexeme Text)
thenBranch Node
next
        Node
eEntry <- case Maybe (Node (Lexeme Text))
elseBranchM of
            Just Node (Lexeme Text)
e  -> Node (Lexeme Text) -> Node -> BuildM Node
buildStmt Node (Lexeme Text)
e Node
next
            Maybe (Node (Lexeme Text))
Nothing -> Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
next
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
TrueBranch Node
tEntry
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
FalseBranch Node
eEntry
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

    WhileStmt Node (Lexeme Text)
cond Node (Lexeme Text)
body -> do
        Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
BranchNode Node (Lexeme Text)
cond)
        Node
bEntry <- (BuildEnv -> BuildEnv) -> BuildM Node -> BuildM Node
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\BuildEnv
env -> BuildEnv
env { envBreak :: Maybe Node
envBreak = Node -> Maybe Node
forall a. a -> Maybe a
Just Node
next, envContinue :: Maybe Node
envContinue = Node -> Maybe Node
forall a. a -> Maybe a
Just Node
node' }) (BuildM Node -> BuildM Node) -> BuildM Node -> BuildM Node
forall a b. (a -> b) -> a -> b
$
            Node (Lexeme Text) -> Node -> BuildM Node
buildStmt Node (Lexeme Text)
body Node
node'
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
TrueBranch Node
bEntry
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
FalseBranch Node
next
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

    DoWhileStmt Node (Lexeme Text)
body Node (Lexeme Text)
cond -> do
        Node
condNode <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
BranchNode Node (Lexeme Text)
cond)
        Node
bEntry <- (BuildEnv -> BuildEnv) -> BuildM Node -> BuildM Node
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\BuildEnv
env -> BuildEnv
env { envBreak :: Maybe Node
envBreak = Node -> Maybe Node
forall a. a -> Maybe a
Just Node
next, envContinue :: Maybe Node
envContinue = Node -> Maybe Node
forall a. a -> Maybe a
Just Node
condNode }) (BuildM Node -> BuildM Node) -> BuildM Node -> BuildM Node
forall a b. (a -> b) -> a -> b
$
            Node (Lexeme Text) -> Node -> BuildM Node
buildStmt Node (Lexeme Text)
body Node
condNode
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
condNode EdgeType
TrueBranch Node
bEntry
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
condNode EdgeType
FalseBranch Node
next
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
bEntry

    ForStmt Node (Lexeme Text)
init' Node (Lexeme Text)
cond Node (Lexeme Text)
step Node (Lexeme Text)
body -> do
        Node
condNode <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
BranchNode Node (Lexeme Text)
cond)
        Node
stepNode <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
StmtNode Node (Lexeme Text)
step)
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
stepNode EdgeType
Unconditional Node
condNode

        Node
bEntry <- (BuildEnv -> BuildEnv) -> BuildM Node -> BuildM Node
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\BuildEnv
env -> BuildEnv
env { envBreak :: Maybe Node
envBreak = Node -> Maybe Node
forall a. a -> Maybe a
Just Node
next, envContinue :: Maybe Node
envContinue = Node -> Maybe Node
forall a. a -> Maybe a
Just Node
stepNode }) (BuildM Node -> BuildM Node) -> BuildM Node -> BuildM Node
forall a b. (a -> b) -> a -> b
$
            Node (Lexeme Text) -> Node -> BuildM Node
buildStmt Node (Lexeme Text)
body Node
stepNode
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
condNode EdgeType
TrueBranch Node
bEntry
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
condNode EdgeType
FalseBranch Node
next

        Node
initEntry <- Node (Lexeme Text) -> Node -> BuildM Node
buildStmt Node (Lexeme Text)
init' Node
condNode
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
initEntry

    NodeF (Lexeme Text) (Node (Lexeme Text))
Break -> do
        Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
StmtNode (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node))
        (BuildEnv -> Maybe Node)
-> ReaderT BuildEnv (State BuildState) (Maybe Node)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BuildEnv -> Maybe Node
envBreak ReaderT BuildEnv (State BuildState) (Maybe Node)
-> (Maybe Node -> ReaderT BuildEnv (State BuildState) ())
-> ReaderT BuildEnv (State BuildState) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Node
target -> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
Unconditional Node
target
            Maybe Node
Nothing     -> () -> ReaderT BuildEnv (State BuildState) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

    NodeF (Lexeme Text) (Node (Lexeme Text))
Continue -> do
        Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
StmtNode (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node))
        (BuildEnv -> Maybe Node)
-> ReaderT BuildEnv (State BuildState) (Maybe Node)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BuildEnv -> Maybe Node
envContinue ReaderT BuildEnv (State BuildState) (Maybe Node)
-> (Maybe Node -> ReaderT BuildEnv (State BuildState) ())
-> ReaderT BuildEnv (State BuildState) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Node
target -> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
Unconditional Node
target
            Maybe Node
Nothing     -> () -> ReaderT BuildEnv (State BuildState) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

    Return Maybe (Node (Lexeme Text))
_ -> do
        Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
StmtNode (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node))
        Node
retNode <- (BuildEnv -> Node) -> BuildM Node
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BuildEnv -> Node
envReturn
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
Unconditional Node
retNode
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

    Goto (L AlexPosn
_ LexemeClass
_ Text
name) -> do
        Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
StmtNode (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node))
        (BuildEnv -> Maybe Node)
-> ReaderT BuildEnv (State BuildState) (Maybe Node)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Map Text Node -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name (Map Text Node -> Maybe Node)
-> (BuildEnv -> Map Text Node) -> BuildEnv -> Maybe Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildEnv -> Map Text Node
envLabels) ReaderT BuildEnv (State BuildState) (Maybe Node)
-> (Maybe Node -> ReaderT BuildEnv (State BuildState) ())
-> ReaderT BuildEnv (State BuildState) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Node
target -> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
Unconditional Node
target
            Maybe Node
Nothing     -> () -> ReaderT BuildEnv (State BuildState) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

    Label (L AlexPosn
_ LexemeClass
_ Text
name) Node (Lexeme Text)
body -> do
        Node
node' <- (BuildEnv -> Node) -> BuildM Node
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Node -> Text -> Map Text Node -> Node
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> Node
forall a. HasCallStack => String -> a
error String
"label missing") Text
name (Map Text Node -> Node)
-> (BuildEnv -> Map Text Node) -> BuildEnv -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildEnv -> Map Text Node
envLabels)
        Node
bEntry <- Node (Lexeme Text) -> Node -> BuildM Node
buildStmt Node (Lexeme Text)
body Node
next
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
Unconditional Node
bEntry
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

    SwitchStmt Node (Lexeme Text)
expr [Node (Lexeme Text)]
cases -> do
        Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
BranchNode Node (Lexeme Text)
expr)
        [Node (Lexeme Text)]
-> Node -> Node -> ReaderT BuildEnv (State BuildState) ()
buildCases [Node (Lexeme Text)]
cases Node
node' Node
next
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

    ExprStmt Node (Lexeme Text)
e -> do
        Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
StmtNode (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node))
        if Node (Lexeme Text) -> Bool
isTerminating Node (Lexeme Text)
e
            then do
                Node
retNode <- (BuildEnv -> Node) -> BuildM Node
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BuildEnv -> Node
envReturn
                StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
Unconditional Node
retNode
            else StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
Unconditional Node
next
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

    VarDeclStmt Node (Lexeme Text)
_ Maybe (Node (Lexeme Text))
_ -> do
        Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
StmtNode (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node))
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
Unconditional Node
next
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

    VLA {} -> do
        Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
StmtNode (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node))
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
Unconditional Node
next
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

    PreprocIf Node (Lexeme Text)
cond [Node (Lexeme Text)]
stmts Node (Lexeme Text)
nextBranch ->
        Node (Lexeme Text)
-> [Node (Lexeme Text)]
-> Node (Lexeme Text)
-> Node
-> BuildM Node
buildPreprocBranch Node (Lexeme Text)
cond [Node (Lexeme Text)]
stmts Node (Lexeme Text)
nextBranch Node
next

    PreprocIfdef Lexeme Text
cond [Node (Lexeme Text)]
stmts Node (Lexeme Text)
nextBranch ->
        Node (Lexeme Text)
-> [Node (Lexeme Text)]
-> Node (Lexeme Text)
-> Node
-> BuildM Node
buildPreprocBranch (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text))
-> NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall a b. (a -> b) -> a -> b
$ Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr Lexeme Text
cond) [Node (Lexeme Text)]
stmts Node (Lexeme Text)
nextBranch Node
next

    PreprocIfndef Lexeme Text
cond [Node (Lexeme Text)]
stmts Node (Lexeme Text)
nextBranch ->
        Node (Lexeme Text)
-> [Node (Lexeme Text)]
-> Node (Lexeme Text)
-> Node
-> BuildM Node
buildPreprocBranch (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text))
-> NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall a b. (a -> b) -> a -> b
$ Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr Lexeme Text
cond) [Node (Lexeme Text)]
stmts Node (Lexeme Text)
nextBranch Node
next

    PreprocElif Node (Lexeme Text)
cond [Node (Lexeme Text)]
stmts Node (Lexeme Text)
nextBranch ->
        Node (Lexeme Text)
-> [Node (Lexeme Text)]
-> Node (Lexeme Text)
-> Node
-> BuildM Node
buildPreprocBranch Node (Lexeme Text)
cond [Node (Lexeme Text)]
stmts Node (Lexeme Text)
nextBranch Node
next

    PreprocElse [Node (Lexeme Text)]
stmts ->
        [Node (Lexeme Text)] -> Node -> BuildM Node
buildStmts [Node (Lexeme Text)]
stmts Node
next

    PreprocScopedDefine Node (Lexeme Text)
_ [Node (Lexeme Text)]
stmts Node (Lexeme Text)
_ ->
        [Node (Lexeme Text)] -> Node -> BuildM Node
buildStmts [Node (Lexeme Text)]
stmts Node
next

    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> do
        Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
StmtNode (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node))
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
Unconditional Node
next
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'

buildStmts :: [C.Node (Lexeme Text)] -> Node -> BuildM Node
buildStmts :: [Node (Lexeme Text)] -> Node -> BuildM Node
buildStmts [] Node
next = Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
next
buildStmts (Node (Lexeme Text)
s:[Node (Lexeme Text)]
ss) Node
next = do
    Node
restEntry <- [Node (Lexeme Text)] -> Node -> BuildM Node
buildStmts [Node (Lexeme Text)]
ss Node
next
    Node (Lexeme Text) -> Node -> BuildM Node
buildStmt Node (Lexeme Text)
s Node
restEntry

buildCases :: [C.Node (Lexeme Text)] -> Node -> Node -> BuildM ()
buildCases :: [Node (Lexeme Text)]
-> Node -> Node -> ReaderT BuildEnv (State BuildState) ()
buildCases [Node (Lexeme Text)]
cases Node
switchNode Node
next = do
    [(Node, Node (Lexeme Text))]
caseEntries <- [Node (Lexeme Text)]
-> (Node (Lexeme Text)
    -> ReaderT BuildEnv (State BuildState) (Node, Node (Lexeme Text)))
-> ReaderT BuildEnv (State BuildState) [(Node, Node (Lexeme Text))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Node (Lexeme Text)]
cases ((Node (Lexeme Text)
  -> ReaderT BuildEnv (State BuildState) (Node, Node (Lexeme Text)))
 -> ReaderT
      BuildEnv (State BuildState) [(Node, Node (Lexeme Text))])
-> (Node (Lexeme Text)
    -> ReaderT BuildEnv (State BuildState) (Node, Node (Lexeme Text)))
-> ReaderT BuildEnv (State BuildState) [(Node, Node (Lexeme Text))]
forall a b. (a -> b) -> a -> b
$ \Node (Lexeme Text)
c -> case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
c of
        Case Node (Lexeme Text)
val Node (Lexeme Text)
body -> do
            Node
cNode <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
StmtNode Node (Lexeme Text)
c)
            StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
switchNode (Node (Lexeme Text) -> EdgeType
CaseBranch Node (Lexeme Text)
val) Node
cNode
            (Node, Node (Lexeme Text))
-> ReaderT BuildEnv (State BuildState) (Node, Node (Lexeme Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Node
cNode, Node (Lexeme Text)
body)
        Default Node (Lexeme Text)
body -> do
            Node
dNode <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
StmtNode Node (Lexeme Text)
c)
            StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
switchNode EdgeType
DefaultBranch Node
dNode
            (Node, Node (Lexeme Text))
-> ReaderT BuildEnv (State BuildState) (Node, Node (Lexeme Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Node
dNode, Node (Lexeme Text)
body)
        NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> String
-> ReaderT BuildEnv (State BuildState) (Node, Node (Lexeme Text))
forall a. HasCallStack => String -> a
error String
"invalid switch case"

    (Node -> (Node, Node (Lexeme Text)) -> BuildM Node)
-> Node
-> [(Node, Node (Lexeme Text))]
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (\Node
nextCaseEntry (Node
cNode, Node (Lexeme Text)
body) -> do
        Node
bodyEntry <- (BuildEnv -> BuildEnv) -> BuildM Node -> BuildM Node
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\BuildEnv
env -> BuildEnv
env { envBreak :: Maybe Node
envBreak = Node -> Maybe Node
forall a. a -> Maybe a
Just Node
next }) (BuildM Node -> BuildM Node) -> BuildM Node -> BuildM Node
forall a b. (a -> b) -> a -> b
$
            Node (Lexeme Text) -> Node -> BuildM Node
buildStmt Node (Lexeme Text)
body Node
nextCaseEntry
        StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
cNode EdgeType
Unconditional Node
bodyEntry
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
bodyEntry
        ) Node
next ([(Node, Node (Lexeme Text))] -> [(Node, Node (Lexeme Text))]
forall a. [a] -> [a]
reverse [(Node, Node (Lexeme Text))]
caseEntries)

buildPreprocBranch :: C.Node (Lexeme Text) -> [C.Node (Lexeme Text)] -> C.Node (Lexeme Text) -> Node -> BuildM Node
buildPreprocBranch :: Node (Lexeme Text)
-> [Node (Lexeme Text)]
-> Node (Lexeme Text)
-> Node
-> BuildM Node
buildPreprocBranch Node (Lexeme Text)
cond [Node (Lexeme Text)]
stmts Node (Lexeme Text)
nextBranch Node
next = do
    Node
node' <- NodeKind -> BuildM Node
newNode (Node (Lexeme Text) -> NodeKind
BranchNode Node (Lexeme Text)
cond)
    Node
tEntry <- [Node (Lexeme Text)] -> Node -> BuildM Node
buildStmts [Node (Lexeme Text)]
stmts Node
next
    Node
eEntry <- Node (Lexeme Text) -> Node -> BuildM Node
buildStmt Node (Lexeme Text)
nextBranch Node
next
    StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
TrueBranch Node
tEntry
    StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (State BuildState) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (State BuildState) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node' EdgeType
FalseBranch Node
eEntry
    Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node'