diff --git a/common/FlowGraph.hs b/common/FlowGraph.hs index 8cca517..a03a6a7 100644 --- a/common/FlowGraph.hs +++ b/common/FlowGraph.hs @@ -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 diff --git a/common/FlowGraphTest.hs b/common/FlowGraphTest.hs index cf7c9a4..49297cd 100644 --- a/common/FlowGraphTest.hs +++ b/common/FlowGraphTest.hs @@ -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