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

import           Control.Monad              (unless)
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, identToString)
import           Language.C.Data.Name       (Name)
import           Language.C.Data.Node       (NodeInfo, nameOfNode)
import           Language.C.Syntax.AST
import           Tokstyle.C.Analysis.Known  (noReturn)

-- | 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
$cshowsPrec :: Int -> Node -> ShowS
showsPrec :: Int -> Node -> ShowS
$cshow :: Node -> String
show :: Node -> String
$cshowList :: [Node] -> ShowS
showList :: [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
$cshowsPrec :: Int -> NodeKind -> ShowS
showsPrec :: Int -> NodeKind -> ShowS
$cshow :: NodeKind -> String
show :: NodeKind -> String
$cshowList :: [NodeKind] -> ShowS
showList :: [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
$cshowsPrec :: Int -> EdgeType -> ShowS
showsPrec :: Int -> EdgeType -> ShowS
$cshow :: EdgeType -> String
show :: EdgeType -> String
$cshowList :: [EdgeType] -> ShowS
showList :: [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
    , BuildEnv -> Map Name Node
envCases    :: Map Name 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 = i + 1 }
    Node -> State BuildState Node
forall a. a -> StateT BuildState Identity a
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 (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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
-> Map Name Node
-> BuildEnv
BuildEnv Maybe Node
forall a. Maybe a
Nothing Maybe Node
forall a. Maybe a
Nothing Node
exitNode Map Ident Node
labels Map Name Node
forall k a. Map k a
Map.empty
        (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 CStat
s) = CStat -> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStat
s
    collectBlockItem CCompoundBlockItem NodeInfo
_              = () -> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall a.
a -> StateT (Map Ident Node) (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    collectStat :: CStat -> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat = \case
        CLabel Ident
i CStat
s [CAttribute NodeInfo]
_ NodeInfo
ni    -> do
            Node
node <- State BuildState Node
-> StateT (Map Ident Node) (StateT BuildState Identity) Node
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Ident Node) m a
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 (CStat -> NodeKind
StatNode (Maybe CExpr -> NodeInfo -> CStat
forall a. Maybe (CExpression a) -> a -> CStatement a
CExpr Maybe CExpr
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
            CStat -> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStat
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 CExpr
_ CStat
t Maybe CStat
e NodeInfo
_        -> CStat -> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStat
t StateT (Map Ident Node) (StateT BuildState Identity) ()
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
-> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall a b.
StateT (Map Ident Node) (StateT BuildState Identity) a
-> StateT (Map Ident Node) (StateT BuildState Identity) b
-> StateT (Map Ident Node) (StateT BuildState Identity) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT (Map Ident Node) (StateT BuildState Identity) ()
-> (CStat
    -> StateT (Map Ident Node) (StateT BuildState Identity) ())
-> Maybe CStat
-> 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 a.
a -> StateT (Map Ident Node) (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) CStat -> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat Maybe CStat
e
        CSwitch CExpr
_ CStat
s NodeInfo
_      -> CStat -> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStat
s
        CCase CExpr
_ CStat
s NodeInfo
_        -> CStat -> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStat
s
        CCases CExpr
_ CExpr
_ CStat
s NodeInfo
_     -> CStat -> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStat
s
        CDefault CStat
s NodeInfo
_       -> CStat -> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStat
s
        CWhile CExpr
_ CStat
s Bool
_ NodeInfo
_     -> CStat -> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStat
s
        CFor Either (Maybe CExpr) CDecl
_ Maybe CExpr
_ Maybe CExpr
_ CStat
s NodeInfo
_     -> CStat -> StateT (Map Ident Node) (StateT BuildState Identity) ()
collectStat CStat
s
        CStat
_                  -> () -> StateT (Map Ident Node) (StateT BuildState Identity) ()
forall a.
a -> StateT (Map Ident Node) (StateT BuildState Identity) a
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 = Map.insertWith (++) from [(et, to)] (stateEdges s) }

buildBlock :: [CBlockItem] -> Node -> BuildM Node
buildBlock :: [CCompoundBlockItem NodeInfo] -> Node -> BuildM Node
buildBlock [] Node
next = Node -> BuildM Node
forall a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
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 CStat
s) Node
next = CStat -> Node -> BuildM Node
buildStat CStat
s Node
next
buildItem (CBlockDecl CDecl
d) Node
next = do
    Node
node <- NodeKind -> BuildM Node
newNode (CDecl -> NodeKind
DeclNode CDecl
d)
    StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node
buildItem (CNestedFunDef CFunctionDef NodeInfo
_) Node
next = Node -> BuildM Node
forall a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
next

buildStat :: CStat -> Node -> BuildM Node
buildStat :: CStat -> Node -> BuildM Node
buildStat CStat
stat Node
next = case CStat
stat of
    CLabel Ident
i CStat
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 <- CStat -> Node -> BuildM Node
buildStat CStat
s Node
next
        StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node

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

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

    CWhile CExpr
cond CStat
s Bool
isDo NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CExpr -> NodeKind
BranchNode CExpr
cond)
        Node
sEntry <- (BuildEnv -> BuildEnv) -> BuildM Node -> BuildM Node
forall a.
(BuildEnv -> BuildEnv)
-> ReaderT BuildEnv (StateT BuildState Identity) a
-> ReaderT BuildEnv (StateT BuildState Identity) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\BuildEnv
env -> BuildEnv
env { envBreak = Just next, envContinue = Just node }) (BuildM Node -> BuildM Node) -> BuildM Node -> BuildM Node
forall a b. (a -> b) -> a -> b
$
            CStat -> Node -> BuildM Node
buildStat CStat
s Node
node
        StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Node -> BuildM Node) -> Node -> BuildM Node
forall a b. (a -> b) -> a -> b
$ if Bool
isDo then Node
sEntry else Node
node

    CSwitch CExpr
cond CStat
s NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CExpr -> NodeKind
BranchNode CExpr
cond)
        [(Maybe Name, EdgeType, Node, Bool)]
labels <- CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)]
caseLabels CStat
s
        let cases :: Map Name Node
cases = [(Name, Node)] -> Map Name Node
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Name
n, Node
c) | (Just Name
n, EdgeType
_, Node
c, Bool
_) <- [(Maybe Name, EdgeType, Node, Bool)]
labels ]
        Node
_ <- (BuildEnv -> BuildEnv) -> BuildM Node -> BuildM Node
forall a.
(BuildEnv -> BuildEnv)
-> ReaderT BuildEnv (StateT BuildState Identity) a
-> ReaderT BuildEnv (StateT BuildState Identity) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\BuildEnv
env -> BuildEnv
env { envBreak = Just next, envCases = cases }) (BuildM Node -> BuildM Node) -> BuildM Node -> BuildM Node
forall a b. (a -> b) -> a -> b
$
            CStat -> Node -> BuildM Node
buildStat CStat
s Node
next
        ((Maybe Name, EdgeType, Node, Bool)
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> [(Maybe Name, EdgeType, Node, Bool)]
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Maybe Name
_, EdgeType
edge, Node
c, Bool
_) -> StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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
edge Node
c) [(Maybe Name, EdgeType, Node, Bool)]
labels
        Bool
-> ReaderT BuildEnv (StateT BuildState Identity) ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
isDefault | (Maybe Name
_, EdgeType
_, Node
_, Bool
isDefault) <- [(Maybe Name, EdgeType, Node, Bool)]
labels ]) (ReaderT BuildEnv (StateT BuildState Identity) ()
 -> ReaderT BuildEnv (StateT BuildState Identity) ())
-> ReaderT BuildEnv (StateT BuildState Identity) ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall a b. (a -> b) -> a -> b
$
            StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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
DefaultBranch Node
next
        Node -> BuildM Node
forall a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node

    CCase CExpr
_ CStat
s NodeInfo
ni -> CStat -> NodeInfo -> Node -> BuildM Node
caseStat CStat
s NodeInfo
ni Node
next
    CCases CExpr
_ CExpr
_ CStat
s NodeInfo
ni -> CStat -> NodeInfo -> Node -> BuildM Node
caseStat CStat
s NodeInfo
ni Node
next
    CDefault CStat
s NodeInfo
ni -> CStat -> NodeInfo -> Node -> BuildM Node
caseStat CStat
s NodeInfo
ni Node
next

    CFor Either (Maybe CExpr) CDecl
init' Maybe CExpr
mCond Maybe CExpr
mStep CStat
s NodeInfo
_ -> do
        Node
condNode <- case Maybe CExpr
mCond of
                         Just CExpr
cond -> NodeKind -> BuildM Node
newNode (CExpr -> NodeKind
BranchNode CExpr
cond)
                         Maybe CExpr
Nothing   -> NodeKind -> BuildM Node
newNode (CStat -> NodeKind
StatNode CStat
stat)
        Node
stepEntry <- case Maybe CExpr
mStep of
                       Just CExpr
step -> do
                           Node
stepNode <- NodeKind -> BuildM Node
newNode (CExpr -> NodeKind
ExprNode CExpr
step)
                           StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
stepNode
                       Maybe CExpr
Nothing -> Node -> BuildM Node
forall a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
condNode

        Node
sEntry <- (BuildEnv -> BuildEnv) -> BuildM Node -> BuildM Node
forall a.
(BuildEnv -> BuildEnv)
-> ReaderT BuildEnv (StateT BuildState Identity) a
-> ReaderT BuildEnv (StateT BuildState Identity) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\BuildEnv
env -> BuildEnv
env { envBreak = Just next, envContinue = Just stepEntry }) (BuildM Node -> BuildM Node) -> BuildM Node -> BuildM Node
forall a b. (a -> b) -> a -> b
$
            CStat -> Node -> BuildM Node
buildStat CStat
s Node
stepEntry

        case Maybe CExpr
mCond of
            Just CExpr
_ -> do
                StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 CExpr
Nothing ->
                StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 CExpr) CDecl
init' of
            Left (Just CExpr
e) -> do
                Node
initNode <- NodeKind -> BuildM Node
newNode (CExpr -> NodeKind
ExprNode CExpr
e)
                StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
initNode
            Right CDecl
d -> do
                Node
initNode <- NodeKind -> BuildM Node
newNode (CDecl -> NodeKind
DeclNode CDecl
d)
                StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
initNode
            Left Maybe CExpr
Nothing -> Node -> BuildM Node
forall a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
condNode

    CReturn Maybe CExpr
_ NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CStat -> NodeKind
StatNode CStat
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 (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node

    CBreak NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CStat -> NodeKind
StatNode CStat
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 a b.
ReaderT BuildEnv (StateT BuildState Identity) a
-> (a -> ReaderT BuildEnv (StateT BuildState Identity) b)
-> ReaderT BuildEnv (StateT BuildState Identity) b
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 (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Node -> BuildM Node
forall a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node

    CCont NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CStat -> NodeKind
StatNode CStat
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 a b.
ReaderT BuildEnv (StateT BuildState Identity) a
-> (a -> ReaderT BuildEnv (StateT BuildState Identity) b)
-> ReaderT BuildEnv (StateT BuildState Identity) b
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 (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Node -> BuildM Node
forall a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node

    CGoto Ident
i NodeInfo
_ -> do
        Node
node <- NodeKind -> BuildM Node
newNode (CStat -> NodeKind
StatNode CStat
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 a b.
ReaderT BuildEnv (StateT BuildState Identity) a
-> (a -> ReaderT BuildEnv (StateT BuildState Identity) b)
-> ReaderT BuildEnv (StateT BuildState Identity) b
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 (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Node -> BuildM Node
forall a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node

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

-- | The labels of a switch body, not counting those of nested switches, with
-- the edges that lead to them and whether they are the @default@ label.
caseLabels :: CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)]
caseLabels :: CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)]
caseLabels = \case
    CCase CExpr
e CStat
s NodeInfo
ni     -> NodeInfo
-> EdgeType
-> Bool
-> CStat
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
label NodeInfo
ni (CExpr -> EdgeType
CaseBranch CExpr
e) Bool
False CStat
s
    CCases CExpr
_ CExpr
_ CStat
s NodeInfo
ni  -> NodeInfo
-> EdgeType
-> Bool
-> CStat
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
label NodeInfo
ni EdgeType
DefaultBranch Bool
False CStat
s
    CDefault CStat
s NodeInfo
ni    -> NodeInfo
-> EdgeType
-> Bool
-> CStat
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
label NodeInfo
ni EdgeType
DefaultBranch Bool
True CStat
s
    CLabel Ident
_ CStat
s [CAttribute NodeInfo]
_ NodeInfo
_   -> CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)]
caseLabels CStat
s
    CCompound [Ident]
_ [CCompoundBlockItem NodeInfo]
bis NodeInfo
_ -> [[(Maybe Name, EdgeType, Node, Bool)]]
-> [(Maybe Name, EdgeType, Node, Bool)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Maybe Name, EdgeType, Node, Bool)]]
 -> [(Maybe Name, EdgeType, Node, Bool)])
-> ReaderT
     BuildEnv
     (StateT BuildState Identity)
     [[(Maybe Name, EdgeType, Node, Bool)]]
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)])
-> [CStat]
-> ReaderT
     BuildEnv
     (StateT BuildState Identity)
     [[(Maybe Name, EdgeType, Node, Bool)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)]
caseLabels [ CStat
s | CBlockStmt CStat
s <- [CCompoundBlockItem NodeInfo]
bis ]
    CIf CExpr
_ CStat
t Maybe CStat
e NodeInfo
_      -> [(Maybe Name, EdgeType, Node, Bool)]
-> [(Maybe Name, EdgeType, Node, Bool)]
-> [(Maybe Name, EdgeType, Node, Bool)]
forall a. [a] -> [a] -> [a]
(++) ([(Maybe Name, EdgeType, Node, Bool)]
 -> [(Maybe Name, EdgeType, Node, Bool)]
 -> [(Maybe Name, EdgeType, Node, Bool)])
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
-> ReaderT
     BuildEnv
     (StateT BuildState Identity)
     ([(Maybe Name, EdgeType, Node, Bool)]
      -> [(Maybe Name, EdgeType, Node, Bool)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)]
caseLabels CStat
t ReaderT
  BuildEnv
  (StateT BuildState Identity)
  ([(Maybe Name, EdgeType, Node, Bool)]
   -> [(Maybe Name, EdgeType, Node, Bool)])
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
forall a b.
ReaderT BuildEnv (StateT BuildState Identity) (a -> b)
-> ReaderT BuildEnv (StateT BuildState Identity) a
-> ReaderT BuildEnv (StateT BuildState Identity) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BuildM [(Maybe Name, EdgeType, Node, Bool)]
-> (CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)])
-> Maybe CStat
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([(Maybe Name, EdgeType, Node, Bool)]
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
forall a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return []) CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)]
caseLabels Maybe CStat
e
    CWhile CExpr
_ CStat
s Bool
_ NodeInfo
_   -> CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)]
caseLabels CStat
s
    CFor Either (Maybe CExpr) CDecl
_ Maybe CExpr
_ Maybe CExpr
_ CStat
s NodeInfo
_   -> CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)]
caseLabels CStat
s
    CStat
_                -> [(Maybe Name, EdgeType, Node, Bool)]
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
forall a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    label :: NodeInfo
-> EdgeType
-> Bool
-> CStat
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
label NodeInfo
ni EdgeType
edge Bool
isDefault CStat
s = do
        Node
node <- NodeKind -> BuildM Node
newNode (CStat -> NodeKind
StatNode (Maybe CExpr -> NodeInfo -> CStat
forall a. Maybe (CExpression a) -> a -> CStatement a
CExpr Maybe CExpr
forall a. Maybe a
Nothing NodeInfo
ni))
        ((NodeInfo -> Maybe Name
nameOfNode NodeInfo
ni, EdgeType
edge, Node
node, Bool
isDefault) (Maybe Name, EdgeType, Node, Bool)
-> [(Maybe Name, EdgeType, Node, Bool)]
-> [(Maybe Name, EdgeType, Node, Bool)]
forall a. a -> [a] -> [a]
:) ([(Maybe Name, EdgeType, Node, Bool)]
 -> [(Maybe Name, EdgeType, Node, Bool)])
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
-> BuildM [(Maybe Name, EdgeType, Node, Bool)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CStat -> BuildM [(Maybe Name, EdgeType, Node, Bool)]
caseLabels CStat
s

-- | A case label: the node the switch jumps to, followed by its statement.
caseStat :: CStat -> NodeInfo -> Node -> BuildM Node
caseStat :: CStat -> NodeInfo -> Node -> BuildM Node
caseStat CStat
s NodeInfo
ni Node
next = do
    Node
sEntry <- CStat -> Node -> BuildM Node
buildStat CStat
s Node
next
    (BuildEnv -> Maybe Node)
-> ReaderT BuildEnv (StateT BuildState Identity) (Maybe Node)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (\BuildEnv
env -> NodeInfo -> Maybe Name
nameOfNode NodeInfo
ni Maybe Name -> (Name -> Maybe Node) -> Maybe Node
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Name -> Map Name Node -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` BuildEnv -> Map Name Node
envCases BuildEnv
env)) ReaderT BuildEnv (StateT BuildState Identity) (Maybe Node)
-> (Maybe Node -> BuildM Node) -> BuildM Node
forall a b.
ReaderT BuildEnv (StateT BuildState Identity) a
-> (a -> ReaderT BuildEnv (StateT BuildState Identity) b)
-> ReaderT BuildEnv (StateT BuildState Identity) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Node
node -> do
            StateT BuildState Identity ()
-> ReaderT BuildEnv (StateT BuildState Identity) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT BuildEnv m a
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 a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
node
        Maybe Node
Nothing -> Node -> BuildM Node
forall a. a -> ReaderT BuildEnv (StateT BuildState Identity) a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
sEntry

-- | Whether a node calls a function that never returns.
endsPath :: Node -> Bool
endsPath :: Node -> Bool
endsPath = \case
    Node Int
_ (StatNode (CExpr (Just (CCall (CVar Ident
f NodeInfo
_) [CExpr]
_ NodeInfo
_)) NodeInfo
_)) ->
        Ident -> String
identToString Ident
f String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
noReturn
    Node
_ -> Bool
False