suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Changed the edge-labelling scheme in the control-flow graph to have beginpar/endpar nodes with matching ids

Browse Source
This commit is contained in:
Neil Brown 2007-10-28 14:55:43 +00:00
parent b6d525fbb8
commit bd14ed56ba
2 changed files with 30 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
common/FlowGraph.hs
View File

@ -31,8 +31,9 @@ import Utils
-- Zero links means it is a terminal node.
-- One Seq link means a normal sequential progression.
-- Multiple Seq links means choice.
-- Multiple Par links means a parallel branch.
data EdgeLabel = ESeq | EPar deriving (Show, Eq, Ord)
-- Multiple Par links means a parallel branch. All outgoing par links should have the same identifier,
-- and this identifier is unique and matches a later endpar link
data EdgeLabel = ESeq | EStartPar Int | EEndPar Int deriving (Show, Eq, Ord)
data OuterType = None | Seq | Par
@ -46,7 +47,7 @@ type FlowGraph a = Gr (FNode a) EdgeLabel
type NodesEdges a = ([LNode (FNode a)],[LEdge EdgeLabel])
type GraphMaker m a b = ErrorT String (StateT (Node, NodesEdges a) m) b
type GraphMaker m a b = ErrorT String (StateT (Node, Int, NodesEdges a) m) b
-- | Builds the instructions to send to GraphViz
makeFlowGraphInstr :: Show a => FlowGraph a -> String
@ -55,21 +56,21 @@ makeFlowGraphInstr = graphviz'
-- The primary reason for having the blank generator take a Meta as an argument is actually for testing. But other uses can simply ignore it if they want.
buildFlowGraph :: Monad m => (Meta -> m a) -> (forall t. Data t => t -> m a) -> A.Structured -> m (Either String (FlowGraph a))
buildFlowGraph blank f s
= do res <- runStateT (runErrorT $ buildStructured None s) (0, ([],[]) )
= do res <- runStateT (runErrorT $ buildStructured None s) (0, 0, ([],[]) )
return $ case res of
(Left err,_) -> Left err
(_,(_,(nodes, edges))) -> Right (mkGraph nodes edges)
(_,(_,_,(nodes, edges))) -> Right (mkGraph nodes edges)
where
-- All the functions return the new graph, and the identifier of the node just added
addNode :: Monad m => (Meta, a) -> GraphMaker m a Node
addNode x = do (n,(nodes, edges)) <- get
put (n+1, ((n, Node x):nodes, edges))
addNode x = do (n,pi,(nodes, edges)) <- get
put (n+1, pi,((n, Node x):nodes, edges))
return n
addEdge :: Monad m => EdgeLabel -> Node -> Node -> GraphMaker m a ()
addEdge label start end = do (n, (nodes, edges)) <- get
put (n + 1, (nodes,(start, end, label):edges))
addEdge label start end = do (n, pi, (nodes, edges)) <- get
put (n + 1, pi, (nodes,(start, end, label):edges))
-- Type commented out because it's not technically correct, but looks right to me:
-- addNode' :: (Monad m, Data t) => Meta -> t -> GraphMaker m a Node
@ -81,6 +82,13 @@ buildFlowGraph blank f s
addDummyNode m = do val <- (lift . lift) (blank m)
addNode (m, val)
addParEdges :: Monad m => Node -> Node -> [(Node,Node)] -> GraphMaker m a ()
addParEdges s e pairs = do (n,pi,(nodes,edges)) <- get
put (n,pi+1,(nodes,edges ++ (concatMap (parEdge pi) pairs)))
where
parEdge :: Int -> (Node, Node) -> [LEdge EdgeLabel]
parEdge id (a,z) = [(s,a,(EStartPar id)),(z,e,(EEndPar id))]
-- Returns a pair of beginning-node, end-node
-- Type commented out because it's not technically correct, but looks right to me:
-- buildStructured :: OuterType -> A.Structured -> GraphMaker m a (Node, Node)
@ -102,7 +110,7 @@ buildFlowGraph blank f s
_ -> do
nStart <- addDummyNode m
nEnd <- addDummyNode m
mapM (\(a,z) -> addEdge EPar nStart a >> addEdge ESeq z nEnd) nodes
addParEdges nStart nEnd nodes
return (nStart, nEnd)
buildStructured _ (A.OnlyP _ p) = buildProcess p
buildStructured outer (A.Spec m spec str)
@ -133,3 +141,4 @@ buildFlowGraph blank f s
-- Types definitely applied to:
-- A.Specification, A.Process, A.Expression
--TODO have scopeIn and scopeOut functions for Specification, and accordingly have two nodes produced by Structured

19
common/FlowGraphTest.hs
View File

@ -146,21 +146,24 @@ testPar = TestList
testPar' 0 [(0,m1)] [] (A.Several m1 [])
,testPar' 1 [(0,m2)] [] (A.OnlyP m1 sm2)
,testPar' 2 [(0,m3)] [] (A.Several m1 [A.OnlyP m2 sm3])
,testPar' 3 [(0,m1), (1, m3), (2, m5), (3,sub m1 1)] [(0,1,EPar),(1,3,ESeq), (0,2,EPar), (2,3,ESeq)] (A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5])
,testPar' 3 [(0,m1), (1, m3), (2, m5), (3,sub m1 1)]
[(0,1,EStartPar 0),(1,3,EEndPar 0), (0,2,EStartPar 0), (2,3,EEndPar 0)]
(A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5])
,testPar' 4 [(0,m1), (1,sub m1 1), (3,m3),(5,m5),(7,m7)]
[(0,3,EPar),(3,1,ESeq),(0,5,EPar),(5,1,ESeq),(0,7,EPar),(7,1,ESeq)]
[(0,3,EStartPar 0),(3,1,EEndPar 0),(0,5,EStartPar 0),(5,1,EEndPar 0),(0,7,EStartPar 0),(7,1,EEndPar 0)]
(A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5,A.OnlyP m6 sm7])
,testPar' 5 [(0,m1), (1, m3), (2, m5), (3,sub m1 1)]
[(0,1,EPar),(1,3,ESeq), (0,2,EPar), (2,3,ESeq)]
[(0,1,EStartPar 0),(1,3,EEndPar 0), (0,2,EStartPar 0), (2,3,EEndPar 0)]
(A.Several m1 [A.Several m1 [A.OnlyP m2 sm3],A.Several m1 [A.OnlyP m4 sm5]])
,testPar' 6 [(0,m1), (1,sub m1 1),(3,m3),(5,m5),(7,m7),(9,m9),(10,m10),(11,sub m10 1)]
[(10,3,EPar),(10,5,EPar),(10,7,EPar),(3,11,ESeq),(5,11,ESeq),(7,11,ESeq)
,(0,10,EPar),(11,1,ESeq),(0,9,EPar),(9,1,ESeq)]
[(10,3,EStartPar 0),(10,5,EStartPar 0),(10,7,EStartPar 0),(3,11,EEndPar 0),(5,11,EEndPar 0),(7,11,EEndPar 0)
,(0,10,EStartPar 1),(11,1,EEndPar 1),(0,9,EStartPar 1),(9,1,EEndPar 1)]
(A.Several m1 [A.Several m10 [A.OnlyP m2 sm3,A.OnlyP m4 sm5,A.OnlyP m6 sm7], A.OnlyP m8 sm9])
,testPar' 10 [(0,m1), (1, m3), (2, m5), (3,sub m1 1), (4, m6)] [(0,4,EPar),(4,1,ESeq),(1,3,ESeq), (0,2,EPar), (2,3,ESeq)]
(A.Several m1 [A.Spec m6 (someSpec m7) $ A.OnlyP m2 sm3,A.OnlyP m4 sm5])
,testPar' 10 [(0,m1), (1, m3), (2, m5), (3,sub m1 1), (4, m6)]
[(0,4,EStartPar 0),(4,1,ESeq),(1,3,EEndPar 0), (0,2,EStartPar 0), (2,3,EEndPar 0)]
(A.Several m1 [A.Spec m6 (someSpec m7) $ A.OnlyP m2 sm3,A.OnlyP m4 sm5])
--TODO test nested pars
]
where
testPar' :: Int -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Structured -> Test