{-# LANGUAGE LambdaCase #-}
module Tokstyle.C.Analysis.CFG
    ( Node (..)
    , NodeKind (..)
    , EdgeType (..)
    , Edge
    , CFG
    , fromFunDef
    ) where

import           Control.Monad.Reader
import           Control.Monad.State
import           Data.Map.Strict            (Map)
import qualified Data.Map.Strict            as Map
import           Language.C.Analysis.SemRep (FunDef (..))
import           Language.C.Data.Ident      (Ident)
import           Language.C.Syntax.AST

-- | 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
    | StatNode CStat
    | DeclNode CDecl
    | ExprNode CExpr
    | BranchNode CExpr
    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 CExpr
    | 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
    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 Ident Node
envLabels   :: Map Ident 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

-- | Build a CFG from a function definition.
fromFunDef :: FunDef -> (Node, CFG)
fromFunDef :: FunDef -> (Node, CFG)
fromFunDef (FunDef VarDecl
_ (CCompound [Ident]
_ [CCompoundBlockItem NodeInfo]
items NodeInfo
_) NodeInfo
_) =
    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 Ident Node
labels, BuildState
s2) = State BuildState (Map Ident Node)
-> BuildState -> (Map Ident Node, BuildState)
forall s a. State s a -> s -> (a, s)
runState (StateT (Map Ident Node) (StateT BuildState Identity) ()
-> Map Ident Node -> State BuildState (Map Ident Node)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT ((CCompoundBlockItem NodeInfo
 -> StateT (Map Ident Node) (StateT BuildState Identity) ())
-> [CCompoundBlockItem NodeInfo]
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CCompoundBlockItem NodeInfo
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectBlockItem [CCompoundBlockItem NodeInfo]
items) Map Ident Node
forall k a. Map k a
Map.empty) BuildState
s1
        env :: BuildEnv
env = Maybe Node -> Maybe Node -> Node -> Map Ident Node -> BuildEnv
BuildEnv Maybe Node
forall a. Maybe a
Nothing Maybe Node
forall a. Maybe a
Nothing Node
exitNode Map Ident 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 ([CCompoundBlockItem NodeInfo] -> Node -> BuildM Node
buildBlock [CCompoundBlockItem NodeInfo]
items 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)
  where
    collectBlockItem :: CCompoundBlockItem NodeInfo
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectBlockItem (CBlockStmt CStatement NodeInfo
s) = CStatement NodeInfo
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStatement NodeInfo
s
    collectBlockItem CCompoundBlockItem NodeInfo
_              = () -> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    collectStat :: CStatement NodeInfo
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat = \case
        CLabel Ident
i CStatement NodeInfo
s [CAttribute NodeInfo]
_ NodeInfo
ni    -> do
            Node
node <- State BuildState Node
-> StateT (Map Ident Node) (StateT BuildState Identity) Node
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State BuildState Node
 -> StateT (Map Ident Node) (StateT BuildState Identity) Node)
-> State BuildState Node
-> StateT (Map Ident Node) (StateT BuildState Identity) Node
forall a b. (a -> b) -> a -> b
$ NodeKind -> State BuildState Node
newNodeState (CStatement NodeInfo -> NodeKind
StatNode (Maybe (CExpression NodeInfo) -> NodeInfo -> CStatement NodeInfo
forall a. Maybe (CExpression a) -> a -> CStatement a
CExpr Maybe (CExpression NodeInfo)
forall a. Maybe a
Nothing NodeInfo
ni))
            (Map Ident Node -> Map Ident Node)
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map Ident Node -> Map Ident Node)
 -> StateT (Map Ident Node) (StateT BuildState Identity) ())
-> (Map Ident Node -> Map Ident Node)
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall a b. (a -> b) -> a -> b
$ Ident -> Node -> Map Ident Node -> Map Ident Node
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Ident
i Node
node
            CStatement NodeInfo
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStatement NodeInfo
s
        CCompound [Ident]
_ [CCompoundBlockItem NodeInfo]
bis NodeInfo
_  -> (CCompoundBlockItem NodeInfo
 -> StateT (Map Ident Node) (StateT BuildState Identity) ())
-> [CCompoundBlockItem NodeInfo]
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CCompoundBlockItem NodeInfo
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectBlockItem [CCompoundBlockItem NodeInfo]
bis
        CIf CExpression NodeInfo
_ CStatement NodeInfo
t Maybe (CStatement NodeInfo)
e NodeInfo
_        -> CStatement NodeInfo
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStatement NodeInfo
t StateT (Map Ident Node) (StateT BuildState Identity) ()
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT (Map Ident Node) (StateT BuildState Identity) ()
-> (CStatement NodeInfo
    -> StateT (Map Ident Node) (StateT BuildState Identity) ())
-> Maybe (CStatement NodeInfo)
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) CStatement NodeInfo
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat Maybe (CStatement NodeInfo)
e
        CSwitch CExpression NodeInfo
_ CStatement NodeInfo
s NodeInfo
_      -> CStatement NodeInfo
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStatement NodeInfo
s
        CWhile CExpression NodeInfo
_ CStatement NodeInfo
s Bool
_ NodeInfo
_     -> CStatement NodeInfo
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStatement NodeInfo
s
        CFor Either (Maybe (CExpression NodeInfo)) (CDeclaration NodeInfo)
_ Maybe (CExpression NodeInfo)
_ Maybe (CExpression NodeInfo)
_ CStatement NodeInfo
s NodeInfo
_     -> CStatement NodeInfo
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStatement NodeInfo
s
        CStatement NodeInfo
_                  -> () -> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

fromFunDef FunDef
_ = (Int -> NodeKind -> Node
Node Int
0 NodeKind
ExitNode, CFG
forall k a. Map k a
Map.empty)

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) }

buildBlock :: [CBlockItem] -> Node -> BuildM Node
buildBlock :: [CCompoundBlockItem NodeInfo] -> Node -> BuildM Node
buildBlock [] Node
next = Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
next
buildBlock (CCompoundBlockItem NodeInfo
item:[CCompoundBlockItem NodeInfo]
items) Node
next = do
    Node
restEntry <- [CCompoundBlockItem NodeInfo] -> Node -> BuildM Node
buildBlock [CCompoundBlockItem NodeInfo]
items Node
next
    CCompoundBlockItem NodeInfo -> Node -> BuildM Node
buildItem CCompoundBlockItem NodeInfo
item Node
restEntry

buildItem :: CBlockItem -> Node -> BuildM Node
buildItem :: CCompoundBlockItem NodeInfo -> Node -> BuildM Node
buildItem (CBlockStmt CStatement NodeInfo
s) Node
next = CStatement NodeInfo -> Node -> BuildM Node
buildStat CStatement NodeInfo
s Node
next
buildItem (CBlockDecl CDeclaration NodeInfo
d) Node
next = do
    Node
node <- NodeKind -> BuildM Node
newNode (CDeclaration NodeInfo -> NodeKind
DeclNode CDeclaration NodeInfo
d)
    StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
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
buildItem (CNestedFunDef CFunctionDef NodeInfo
_) Node
next = Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
next

buildStat :: CStat -> Node -> BuildM Node
buildStat :: CStatement NodeInfo -> Node -> BuildM Node
buildStat CStatement NodeInfo
stat Node
next = case CStatement NodeInfo
stat of
    CLabel Ident
i CStatement NodeInfo
s [CAttribute NodeInfo]
_ NodeInfo
_ -> do
        Node
node <- (BuildEnv -> Node) -> BuildM Node
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Node -> Ident -> Map Ident 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") Ident
i (Map Ident Node -> Node)
-> (BuildEnv -> Map Ident Node) -> BuildEnv -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildEnv -> Map Ident Node
envLabels)
        Node
sEntry <- CStatement NodeInfo -> Node -> BuildM Node
buildStat CStatement NodeInfo
s Node
next
        StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node EdgeType
Unconditional Node
sEntry
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node

    CExpr (Just CExpression NodeInfo
_) NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CStatement NodeInfo -> NodeKind
StatNode CStatement NodeInfo
stat)
        StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
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

    CExpr Maybe (CExpression NodeInfo)
Nothing NodeInfo
_ -> Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
next

    CCompound [Ident]
_ [CCompoundBlockItem NodeInfo]
items NodeInfo
_ -> [CCompoundBlockItem NodeInfo] -> Node -> BuildM Node
buildBlock [CCompoundBlockItem NodeInfo]
items Node
next

    CIf CExpression NodeInfo
cond CStatement NodeInfo
t Maybe (CStatement NodeInfo)
mElse NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CExpression NodeInfo -> NodeKind
BranchNode CExpression NodeInfo
cond)
        Node
tEntry <- CStatement NodeInfo -> Node -> BuildM Node
buildStat CStatement NodeInfo
t Node
next
        Node
eEntry <- case Maybe (CStatement NodeInfo)
mElse of
            Just CStatement NodeInfo
e  -> CStatement NodeInfo -> Node -> BuildM Node
buildStat CStatement NodeInfo
e Node
next
            Maybe (CStatement NodeInfo)
Nothing -> Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
next
        StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
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 (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
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

    CWhile CExpression NodeInfo
cond CStatement NodeInfo
s Bool
_ NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CExpression NodeInfo -> NodeKind
BranchNode CExpression NodeInfo
cond)
        Node
sEntry <- (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
$
            CStatement NodeInfo -> Node -> BuildM Node
buildStat CStatement NodeInfo
s Node
node
        StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
node EdgeType
TrueBranch Node
sEntry
        StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
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

    CFor Either (Maybe (CExpression NodeInfo)) (CDeclaration NodeInfo)
init' Maybe (CExpression NodeInfo)
mCond Maybe (CExpression NodeInfo)
mStep CStatement NodeInfo
s NodeInfo
_ -> do
        Node
condNode <- case Maybe (CExpression NodeInfo)
mCond of
                         Just CExpression NodeInfo
cond -> NodeKind -> BuildM Node
newNode (CExpression NodeInfo -> NodeKind
BranchNode CExpression NodeInfo
cond)
                         Maybe (CExpression NodeInfo)
Nothing   -> NodeKind -> BuildM Node
newNode (CStatement NodeInfo -> NodeKind
StatNode CStatement NodeInfo
stat)
        Node
stepEntry <- case Maybe (CExpression NodeInfo)
mStep of
                       Just CExpression NodeInfo
step -> do
                           Node
stepNode <- NodeKind -> BuildM Node
newNode (CExpression NodeInfo -> NodeKind
ExprNode CExpression NodeInfo
step)
                           StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
stepNode EdgeType
Unconditional Node
condNode
                           Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
stepNode
                       Maybe (CExpression NodeInfo)
Nothing -> Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
condNode

        Node
sEntry <- (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
stepEntry }) (BuildM Node -> BuildM Node) -> BuildM Node -> BuildM Node
forall a b. (a -> b) -> a -> b
$
            CStatement NodeInfo -> Node -> BuildM Node
buildStat CStatement NodeInfo
s Node
stepEntry

        case Maybe (CExpression NodeInfo)
mCond of
            Just CExpression NodeInfo
_ -> do
                StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
condNode EdgeType
TrueBranch Node
sEntry
                StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
condNode EdgeType
FalseBranch Node
next
            Maybe (CExpression NodeInfo)
Nothing ->
                StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
condNode EdgeType
Unconditional Node
sEntry

        case Either (Maybe (CExpression NodeInfo)) (CDeclaration NodeInfo)
init' of
            Left (Just CExpression NodeInfo
e) -> do
                Node
initNode <- NodeKind -> BuildM Node
newNode (CExpression NodeInfo -> NodeKind
ExprNode CExpression NodeInfo
e)
                StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
initNode EdgeType
Unconditional Node
condNode
                Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
initNode
            Right CDeclaration NodeInfo
d -> do
                Node
initNode <- NodeKind -> BuildM Node
newNode (CDeclaration NodeInfo -> NodeKind
DeclNode CDeclaration NodeInfo
d)
                StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall a b. (a -> b) -> a -> b
$ Node -> EdgeType -> Node -> StateT BuildState Identity ()
addEdgeM Node
initNode EdgeType
Unconditional Node
condNode
                Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
initNode
            Left Maybe (CExpression NodeInfo)
Nothing -> Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
condNode

    CReturn Maybe (CExpression NodeInfo)
_ NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CStatement NodeInfo -> NodeKind
StatNode CStatement NodeInfo
stat)
        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 (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
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

    CBreak NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CStatement NodeInfo -> NodeKind
StatNode CStatement NodeInfo
stat)
        (BuildEnv -> Maybe Node)
-> ReaderT BuildEnv (StateT BuildState Identity) (Maybe Node)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BuildEnv -> Maybe Node
envBreak ReaderT BuildEnv (StateT BuildState Identity) (Maybe Node)
-> (Maybe Node -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Node
target -> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
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 (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node

    CCont NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CStatement NodeInfo -> NodeKind
StatNode CStatement NodeInfo
stat)
        (BuildEnv -> Maybe Node)
-> ReaderT BuildEnv (StateT BuildState Identity) (Maybe Node)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BuildEnv -> Maybe Node
envContinue ReaderT BuildEnv (StateT BuildState Identity) (Maybe Node)
-> (Maybe Node -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Node
target -> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
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 (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node

    CGoto Ident
i NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CStatement NodeInfo -> NodeKind
StatNode CStatement NodeInfo
stat)
        (BuildEnv -> Maybe Node)
-> ReaderT BuildEnv (StateT BuildState Identity) (Maybe Node)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Ident -> Map Ident Node -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
i (Map Ident Node -> Maybe Node)
-> (BuildEnv -> Map Ident Node) -> BuildEnv -> Maybe Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildEnv -> Map Ident Node
envLabels) ReaderT BuildEnv (StateT BuildState Identity) (Maybe Node)
-> (Maybe Node -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Node
target -> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
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 (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Node -> BuildM Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node

    CStatement NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CStatement NodeInfo -> NodeKind
StatNode CStatement NodeInfo
stat)
        StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BuildState Identity ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
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