From 5e87aa1e73618b42027e8a9630a45f3c409589a0 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sun, 10 Feb 2008 20:07:02 +0000 Subject: [PATCH] Refactored the way the flow-graph building handles the different Structured items, and tweaked some tests accordingly --- common/FlowGraph.hs | 334 +++++++++++++++++++++++----------------- common/FlowGraphTest.hs | 61 ++++---- 2 files changed, 225 insertions(+), 170 deletions(-) diff --git a/common/FlowGraph.hs b/common/FlowGraph.hs index 2ad3897..7d30bf6c 100644 --- a/common/FlowGraph.hs +++ b/common/FlowGraph.hs @@ -65,9 +65,6 @@ import Utils -- and this identifier is unique and matches a later endpar link data EdgeLabel = ESeq | EStartPar Int | EEndPar Int deriving (Show, Eq, Ord) ---If is (previous condition) (final node) -data OuterType = ONone | OSeq | OPar Int (Node, Node) | OCase (Node,Node) | OIf Node Node deriving (Show) - -- | A type used to build up tree-modifying functions. When given an inner modification function, -- it returns a modification function for the whole tree. The functions are monadic, to -- provide flexibility; you can always use the Identity monad. @@ -241,10 +238,13 @@ routeList n f xs x' <- f x return (pre ++ [x'] ++ suf) -mapMR :: forall inner mAlter mLabel label structType. (Monad mLabel, Monad mAlter) => ASTModifier mAlter [inner] structType -> (inner -> ASTModifier mAlter inner structType -> GraphMaker mLabel mAlter label structType (Node,Node)) -> [inner] -> GraphMaker mLabel mAlter label structType [(Node,Node)] +mapMR :: forall inner mAlter mLabel label retType structType. (Monad mLabel, Monad mAlter) => + ASTModifier mAlter [inner] structType -> + (inner -> ASTModifier mAlter inner structType -> GraphMaker mLabel mAlter label structType retType) -> + [inner] -> GraphMaker mLabel mAlter label structType [retType] mapMR outerRoute func xs = mapM funcAndRoute (zip [0..] xs) where - funcAndRoute :: (Int, inner) -> GraphMaker mLabel mAlter label structType (Node,Node) + funcAndRoute :: (Int, inner) -> GraphMaker mLabel mAlter label structType retType funcAndRoute (ind,x) = func x (outerRoute @-> routeList ind) @@ -270,129 +270,192 @@ joinPairs m [] = addDummyNode m >>* mkPair joinPairs m nodes = do sequence_ $ mapPairs (\(_,s) (e,_) -> addEdge ESeq s e) nodes return (fst (head nodes), snd (last nodes)) - -buildStructuredP :: (Monad mLabel, Monad mAlter) => - OuterType -> A.Structured A.Process -> ASTModifier mAlter (A.Structured A.Process) structType -> GraphMaker mLabel mAlter label structType (Either Bool (Node, Node)) -buildStructuredP = buildStructured (\_ r p -> buildProcess p r) -buildStructuredC :: (Monad mLabel, Monad mAlter) => - OuterType -> A.Structured A.Choice -> ASTModifier mAlter (A.Structured A.Choice) structType -> GraphMaker mLabel mAlter label structType (Either Bool (Node, Node)) -buildStructuredC = buildStructured buildOnlyChoice -buildStructuredO :: (Monad mLabel, Monad mAlter) => - OuterType -> A.Structured A.Option -> ASTModifier mAlter (A.Structured A.Option) structType -> GraphMaker mLabel mAlter label structType (Either Bool (Node, Node)) -buildStructuredO = buildStructured buildOnlyOption - --- Returns a pair of beginning-node, end-node --- Bool indicates emptiness (False = empty, True = there was something) -buildStructured :: forall a mAlter mLabel label structType. (Monad mLabel, Monad mAlter, Data a) => - (OuterType -> ASTModifier mAlter a structType -> a -> GraphMaker mLabel mAlter label structType (Node, Node)) -> - OuterType -> A.Structured a -> ASTModifier mAlter (A.Structured a) structType -> GraphMaker mLabel mAlter label structType (Either Bool (Node, Node)) -buildStructured f outer (A.Several m ss) route - = do case outer of - ONone -> -- If there is no context, they should be left as disconnected graphs. - do nodes <- mapMRE decompSeveral (buildStructured f outer) ss - return $ Left $ nonEmpty nodes - OSeq -> do nodes <- mapMRE decompSeveral (buildStructured f outer) ss - case nodes of - Left hadNodes -> return $ Left hadNodes - Right nodes' -> joinPairs m nodes' >>* Right - OPar pId (nStart, nEnd) -> - do nodes <- mapMRE decompSeveral (buildStructured f outer) ss - addParEdges pId (nStart, nEnd) $ either (const []) id nodes - return $ Left $ nonEmpty nodes - --Because the conditions in If statements are chained together, we - --must fold the specs, not map them independently - OIf prev end -> foldM foldIf (prev,end) (zip [0..] ss) >>* Right - where - foldIf :: (Node,Node) -> (Int,A.Structured a) -> GraphMaker mLabel mAlter label structType (Node, Node) - foldIf (prev,end) (ind,s) = do nodes <- buildStructured f (OIf prev end) s $ decompSeveral @-> (routeList ind) - case nodes of - Left {} -> return (prev,end) - Right (prev',_) -> return (prev', end) - _ -> do nodes <- mapMRE decompSeveral (buildStructured f outer) ss - return $ Left $ nonEmpty nodes - where - decompSeveral :: ASTModifier mAlter [A.Structured a] structType - decompSeveral = route22 route A.Several - -buildStructured f outer (A.Spec m spec str) route +addSpecNodes :: (Monad mAlter, Monad mLabel, Data a) => A.Specification -> ASTModifier mAlter (A.Structured a) structType -> GraphMaker mLabel mAlter label structType (Node, Node) +addSpecNodes spec route = do n <- addNode' (findMeta spec) labelScopeIn spec (AlterSpec $ route23 route A.Spec) n' <- addNode' (findMeta spec) labelScopeOut spec (AlterSpec $ route23 route A.Spec) + return (n, n') - -- If it's a process or function spec we must process it too. No need to - -- connect it up to the outer part though - case spec of - (A.Specification _ _ (A.Proc m _ args p)) -> - let procRoute = (route33 (route23 route A.Spec) A.Specification) in - addNewSubProcFunc m args (Left (p, route44 procRoute A.Proc)) (route34 procRoute A.Proc) - (A.Specification _ _ (A.Function m _ _ args s)) -> - let funcRoute = (route33 (route23 route A.Spec) A.Specification) in - addNewSubProcFunc m args (Right (s, route55 funcRoute A.Function)) (route45 funcRoute A.Function) - _ -> return () +-- Descends into process or function specifications, but doesn't join them up. Any other specifications are ignored +buildProcessOrFunctionSpec :: (Monad mAlter, Monad mLabel) => A.Specification -> ASTModifier mAlter (A.Specification) structType -> + GraphMaker mLabel mAlter label structType () +buildProcessOrFunctionSpec (A.Specification _ _ (A.Proc m _ args p)) route + = let procRoute = (route33 route A.Specification) in + addNewSubProcFunc m args (Left (p, route44 procRoute A.Proc)) (route34 procRoute A.Proc) +buildProcessOrFunctionSpec (A.Specification _ _ (A.Function m _ _ args s)) route + = let funcRoute = (route33 route A.Specification) in + addNewSubProcFunc m args (Right (s, route55 funcRoute A.Function)) (route45 funcRoute A.Function) +buildProcessOrFunctionSpec _ _ = return () - outer' <- case outer of - OPar {} -> getNextParEdgeId >>* flip OPar (n,n') - _ -> return outer - nodes <- buildStructured f outer' str (route33 route A.Spec) +-- All the various types of Structured (SEQ, PAR, ALT, IF, CASE, input-CASE, VALOF) deal with their nodes so differently +-- that I have ended up having a different function for each of them, because there is so little commonality +-- +-- They differ in many ways, one of the main ones being who has responsibility for adding the links. In the (easy) case +-- of SEQ, we always return (begin, end) nodes and let the caller draw in the links. In the case of PAR, the tricky +-- aspect of nested Specs and such means it's better to pass the outermost begin/end nodes for the PAR into the function +-- and let each sub-function draw the links. + +buildStructuredAST :: (Monad mLabel, Monad mAlter) => A.Structured () -> ASTModifier mAlter (A.Structured ()) () -> + GraphMaker mLabel mAlter label () () +buildStructuredAST (A.Several _ ss) route + = do mapMR (route22 route A.Several) buildStructuredAST ss + return () +buildStructuredAST (A.Spec _ spec str) route + = do buildProcessOrFunctionSpec spec (route23 route A.Spec) + buildStructuredAST str (route33 route A.Spec) +buildStructuredAST s _ = throwError $ "Unexpected element at top-level: " ++ show s + +buildStructuredEL :: (Monad mLabel, Monad mAlter) => A.Structured A.ExpressionList -> ASTModifier mAlter (A.Structured A.ExpressionList) structType -> + GraphMaker mLabel mAlter label structType (Node, Node) +buildStructuredEL (A.Only m el) route = addNodeExpressionList m el (route22 route A.Only) >>* mkPair +buildStructuredEL (A.ProcThen _ p str) route + = do (ps, pe) <- buildProcess p (route23 route A.ProcThen) + (ss, se) <- buildStructuredEL str (route33 route A.ProcThen) + addEdge ESeq pe ss + return (ps, se) +buildStructuredEL (A.Spec m spec str) route + = do (n,n') <- addSpecNodes spec route + buildProcessOrFunctionSpec spec (route23 route A.Spec) + (s,e) <- buildStructuredEL str (route33 route A.Spec) + addEdge ESeq n s + addEdge ESeq e n' + return (n, n') +buildStructuredEL s _ = throwError $ "Unexpected element in function: " ++ show s + + +buildStructuredSeq :: (Monad mLabel, Monad mAlter) => A.Structured A.Process -> ASTModifier mAlter (A.Structured A.Process) structType -> + GraphMaker mLabel mAlter label structType (Node, Node) +buildStructuredSeq (A.Several m ss) route + = do nodes <- mapMR (route22 route A.Several) buildStructuredSeq ss + joinPairs m nodes +buildStructuredSeq (A.Spec m spec str) route + = do (n,n') <- addSpecNodes spec route + buildProcessOrFunctionSpec spec (route23 route A.Spec) + (s,e) <- buildStructuredSeq str (route33 route A.Spec) + addEdge ESeq n s + addEdge ESeq e n' + return (n, n') +buildStructuredSeq (A.Rep m rep str) route + = let alter = AlterReplicator $ route23 route A.Rep in + do n <- addNode' (findMeta rep) labelReplicator rep alter + (s,e) <- buildStructuredSeq str (route33 route A.Rep) + addEdge ESeq n s + addEdge ESeq e n + return (n, n) +buildStructuredSeq (A.Only _ p) route = buildProcess p (route22 route A.Only) +buildStructuredSeq (A.ProcThen _ p str) route + = do (ps, pe) <- buildProcess p (route23 route A.ProcThen) + (ss, se) <- buildStructuredSeq str (route33 route A.ProcThen) + addEdge ESeq pe ss + return (ps, se) + +buildStructuredPar :: (Monad mLabel, Monad mAlter) => Int -> (Node, Node) -> + A.Structured A.Process -> ASTModifier mAlter (A.Structured A.Process) structType -> + GraphMaker mLabel mAlter label structType (Either Bool (Node, Node)) +buildStructuredPar pId (nStart, nEnd) (A.Several m ss) route + = do nodes <- mapMRE (route22 route A.Several) (buildStructuredPar pId (nStart, nEnd)) ss + addParEdges pId (nStart, nEnd) $ either (const []) id nodes + return $ Left $ nonEmpty nodes +buildStructuredPar pId (nStart, nEnd) (A.Spec m spec str) route + = do (n,n') <- addSpecNodes spec route + pId' <- getNextParEdgeId + buildProcessOrFunctionSpec spec (route23 route A.Spec) + nodes <- buildStructuredPar pId' (n, n') str (route33 route A.Spec) case nodes of Left False -> do addEdge ESeq n n' Left True -> return () Right (s,e) -> do addEdge ESeq n s addEdge ESeq e n' return $ Right (n,n') -buildStructured f outer (A.Rep m rep str) route - = do let alter = AlterReplicator $ route23 route A.Rep - case outer of - OSeq -> do n <- addNode' (findMeta rep) labelReplicator rep alter - nodes <- buildStructured f outer str (route33 route A.Rep) - case nodes of - Right (s,e) -> - do addEdge ESeq n s - addEdge ESeq e n - Left False -> addEdge ESeq n n - Left True -> throwError $ show m ++ " SEQ replicator had non-joined up body when building flow-graph" - return $ Right (n,n) - OPar pId _ -> - do s <- addNode' (findMeta rep) labelReplicator rep alter - e <- addDummyNode m - pId <- getNextParEdgeId - nodes <- buildStructured f (OPar pId (s,e)) str (route33 route A.Rep) - case nodes of - Left False -> addEdge ESeq s e - Left True -> return () - Right (s',e') -> do addEdge (EStartPar pId) s s' - addEdge (EEndPar pId) e' e - return $ Right (s,e) - OIf prev end -> - do repNode <- addNode' (findMeta rep) labelReplicator rep alter - addEdge ESeq prev repNode - nodes <- buildStructured f (OIf repNode end) str (route33 route A.Rep) - - case nodes of - Left False -> return $ Right (repNode, repNode) - Left True -> return $ Right (repNode, repNode) - Right (p,e) -> do addEdge ESeq p repNode - return $ Right (repNode, repNode) - - return $ Right (repNode, end) - _ -> throwError $ "Cannot have replicators inside context: " ++ show outer +buildStructuredPar pId (nStart, nEnd) (A.Rep m rep str) route + = let alter = AlterReplicator $ route23 route A.Rep in + do s <- addNode' (findMeta rep) labelReplicator rep alter + e <- addDummyNode m + pId' <- getNextParEdgeId + nodes <- buildStructuredPar pId' (s,e) str (route33 route A.Rep) + case nodes of + Left False -> addEdge ESeq s e + Left True -> return () + Right (s',e') -> do addEdge (EStartPar pId') s s' + addEdge (EEndPar pId') e' e + return $ Right (s,e) +buildStructuredPar _ _ (A.Only _ p) route = buildProcess p (route22 route A.Only) >>* Right +buildStructuredPar pId (nStart, nEnd) (A.ProcThen m p str) route + = do (ps, pe) <- buildProcess p (route23 route A.ProcThen) + n <- addDummyNode m + pId' <- getNextParEdgeId + nodes <- buildStructuredPar pId' (pe, n) str (route33 route A.ProcThen) + case nodes of + Left False -> return $ Right (ps, pe) + Left True -> return $ Right (ps, n) + Right (s,e) -> do addEdge ESeq pe s + return $ Right (ps, e) -buildStructured f outer (A.Only _ o) route = f outer (route22 route A.Only) o >>* Right -buildStructured _ _ s _ = return $ Left False +buildStructuredCase :: (Monad mLabel, Monad mAlter) => (Node, Node) -> A.Structured A.Option -> ASTModifier mAlter (A.Structured A.Option) structType -> + GraphMaker mLabel mAlter label structType () +buildStructuredCase (nStart, nEnd) (A.Several _ ss) route + = do mapMR (route22 route A.Several) (buildStructuredCase (nStart, nEnd)) ss + return () +buildStructuredCase (nStart, nEnd) (A.ProcThen _ p str) route + = do (ps, pe) <- buildProcess p (route23 route A.ProcThen) + addEdge ESeq nStart ps + buildStructuredCase (pe, nEnd) str (route33 route A.ProcThen) +buildStructuredCase (nStart, nEnd) (A.Only _ o) route + = buildOnlyOption (nStart, nEnd) (route22 route A.Only) o +buildStructuredCase (nStart, nEnd) (A.Spec _ spec str) route + = do (n, n') <- addSpecNodes spec route + addEdge ESeq nStart n + addEdge ESeq n' nEnd + buildStructuredCase (n, n') str (route33 route A.Spec) +buildStructuredCase _ s _ = throwError $ "Unexpected element in CASE statement: " ++ show s -buildOnlyChoice :: (Monad mLabel, Monad mAlter) => OuterType -> ASTModifier mAlter A.Choice structType -> A.Choice -> GraphMaker mLabel mAlter label structType (Node, Node) -buildOnlyChoice outer route (A.Choice m exp p) +buildStructuredIf :: forall mLabel mAlter label structType. (Monad mLabel, Monad mAlter) => (Node, Node) -> A.Structured A.Choice -> ASTModifier mAlter (A.Structured A.Choice) structType -> + GraphMaker mLabel mAlter label structType Node +buildStructuredIf (prev, end) (A.Several _ ss) route + = foldM foldIf prev (zip [0..] ss) + where + foldIf :: Node -> (Int,A.Structured A.Choice) -> GraphMaker mLabel mAlter label structType Node + foldIf prev (ind, s) = buildStructuredIf (prev, end) s $ route22 route A.Several @-> (routeList ind) +buildStructuredIf (prev, end) (A.ProcThen _ p str) route + = do (ps, pe) <- buildProcess p (route23 route A.ProcThen) + addEdge ESeq prev ps + buildStructuredIf (pe, end) str (route33 route A.ProcThen) +buildStructuredIf (prev, end) (A.Only _ c) route + = buildOnlyChoice (prev, end) (route22 route A.Only) c +buildStructuredIf (prev, end) (A.Spec _ spec str) route + -- Specs are tricky in IFs, because they can scope out either + -- at the end of a choice-block, or when moving on to the next + -- choice. But these nodes are not the same because they have + -- different connections leading out of them + = do nIn <- addNode' (findMeta spec) labelScopeIn spec (AlterSpec $ route23 route A.Spec) + nOutBlock <- addNode' (findMeta spec) labelScopeOut spec (AlterSpec $ route23 route A.Spec) + nOutNext <- addNode' (findMeta spec) labelScopeOut spec (AlterSpec $ route23 route A.Spec) + + last <- buildStructuredIf (nIn, nOutBlock) str (route33 route A.Spec) + + addEdge ESeq prev nIn + when (last /= prev) $ -- Only add the edge if there was a block it's connected to! + addEdge ESeq nOutBlock end + addEdge ESeq last nOutNext + return nOutNext +buildStructuredIf (prev, end) (A.Rep _ rep str) route + = do repNode <- addNode' (findMeta rep) labelReplicator rep (AlterReplicator $ route23 route A.Rep) + lastNode <- buildStructuredIf (repNode, end) str (route33 route A.Rep) + addEdge ESeq prev repNode + addEdge ESeq lastNode repNode + return repNode + +buildOnlyChoice :: (Monad mLabel, Monad mAlter) => (Node, Node) -> ASTModifier mAlter A.Choice structType -> A.Choice -> GraphMaker mLabel mAlter label structType Node +buildOnlyChoice (cPrev, cEnd) route (A.Choice m exp p) = do nexp <- addNodeExpression (findMeta exp) exp $ route23 route A.Choice (nbodys, nbodye) <- buildProcess p $ route33 route A.Choice addEdge ESeq nexp nbodys - case outer of - OIf cPrev cEnd -> - do addEdge ESeq cPrev nexp - addEdge ESeq nbodye cEnd - _ -> throwError "Choice found outside IF statement" - return (nexp,nbodye) + addEdge ESeq cPrev nexp + addEdge ESeq nbodye cEnd + return nexp -buildOnlyOption :: (Monad mLabel, Monad mAlter) => OuterType -> ASTModifier mAlter A.Option structType -> A.Option -> GraphMaker mLabel mAlter label structType (Node, Node) -buildOnlyOption outer route opt +buildOnlyOption :: (Monad mLabel, Monad mAlter) => (Node, Node) -> ASTModifier mAlter A.Option structType -> A.Option -> GraphMaker mLabel mAlter label structType () +buildOnlyOption (cStart, cEnd) route opt = do (s,e) <- case opt of (A.Option m es p) -> do @@ -402,12 +465,9 @@ buildOnlyOption outer route opt addEdge ESeq nexpe nbodys return (nexps,nbodye) (A.Else _ p) -> buildProcess p $ route22 route A.Else - case outer of - OCase (cStart, cEnd) -> - do addEdge ESeq cStart s - addEdge ESeq e cEnd - _ -> throwError "Option found outside CASE statement" - return (s,e) + addEdge ESeq cStart s + addEdge ESeq e cEnd + return () addNewSubProcFunc :: (Monad mLabel, Monad mAlter) => Meta -> [A.Formal] -> Either (A.Process, ASTModifier mAlter A.Process structType) (A.Structured A.ExpressionList, ASTModifier mAlter (A.Structured A.ExpressionList) structType) -> @@ -417,28 +477,17 @@ addNewSubProcFunc m args body argsRoute denoteRootNode root bodyNode <- case body of Left (p,route) -> buildProcess p route >>* fst - Right (s,route) -> - do s <- buildStructured (buildEL m) ONone s route - case s of - Left {} -> throwError $ show m ++ " Expected VALOF or specification at top-level of function when building flow-graph" - Right (n,_) -> return n + Right (s,route) -> buildStructuredEL s route >>* fst addEdge ESeq root bodyNode - where - buildEL m _ r el = addNodeExpressionList m el r >>* mkPair buildProcess :: (Monad mLabel, Monad mAlter) => A.Process -> ASTModifier mAlter A.Process structType -> GraphMaker mLabel mAlter label structType (Node, Node) buildProcess (A.Seq m s) route - = do s <- buildStructuredP OSeq s (route22 route A.Seq) - case s of - Left True -> throwError $ show m ++ " SEQ had non-joined up body when building flow-graph" - Left False -> do n <- addDummyNode m - return (n, n) - Right ns -> return ns + = buildStructuredSeq s (route22 route A.Seq) buildProcess (A.Par m _ s) route = do nStart <- addDummyNode m nEnd <- addDummyNode m pId <- getNextParEdgeId - nodes <- buildStructuredP (OPar pId (nStart, nEnd)) s (route33 route A.Par) + nodes <- buildStructuredPar pId (nStart, nEnd) s (route33 route A.Par) case nodes of Left False -> do addEdge ESeq nStart nEnd -- no processes in PAR, join start and end with simple ESeq link Left True -> return () -- already wired up @@ -455,13 +504,14 @@ buildProcess (A.While _ e p) route buildProcess (A.Case m e s) route = do nStart <- addNodeExpression (findMeta e) e (route23 route A.Case) nEnd <- addDummyNode m - buildStructuredO (OCase (nStart,nEnd)) s (route33 route A.Case) + buildStructuredCase (nStart,nEnd) s (route33 route A.Case) return (nStart, nEnd) buildProcess (A.If m s) route = do nStart <- addDummyNode m nEnd <- addDummyNode m - buildStructuredC (OIf nStart nEnd) s (route22 route A.If) + buildStructuredIf (nStart, nEnd) s (route22 route A.If) return (nStart, nEnd) +-- TODO Alt buildProcess p route = addNode' (findMeta p) labelProcess p (AlterProcess route) >>* mkPair @@ -471,27 +521,25 @@ buildProcess p route = addNode' (findMeta p) labelProcess p (AlterProcess route) -- the parameters, only in the result. The mLabel monad is the monad in -- which the labelling must be done; hence the flow-graph is returned inside -- the label monad. -buildFlowGraph :: forall mLabel mAlter label structType. (Monad mLabel, Monad mAlter, Data structType) => +buildFlowGraph :: forall mLabel mAlter label. (Monad mLabel, Monad mAlter) => GraphLabelFuncs mLabel label -> - A.Structured structType -> - mLabel (Either String (FlowGraph' mAlter label structType, [Node])) + A.AST -> + mLabel (Either String (FlowGraph' mAlter label (), [Node])) buildFlowGraph funcs s - = do res <- flip runStateT (0, 0, ([],[]), []) $ flip runReaderT funcs $ runErrorT $ buildStructured (\_ _ _ -> throwError "Did not expect outer-most node to exist in AST") ONone s id + = do res <- flip runStateT (0, 0, ([],[]), []) $ flip runReaderT funcs $ runErrorT $ buildStructuredAST s id return $ case res of (Left err,_) -> Left err - (Right (Left {}),(_,_,(nodes, edges),roots)) -> Right (mkGraph nodes edges, roots) - (Right (Right (root,_)),(_,_,(nodes, edges),roots)) -> Right (mkGraph nodes edges, root : roots) + (Right _,(_,_,(nodes, edges),roots)) -> Right (mkGraph nodes edges, roots) buildFlowGraphP :: forall mLabel mAlter label. (Monad mLabel, Monad mAlter) => GraphLabelFuncs mLabel label -> A.Structured A.Process -> mLabel (Either String (FlowGraph' mAlter label A.Process, [Node])) buildFlowGraphP funcs s - = do res <- flip runStateT (0, 0, ([],[]), []) $ flip runReaderT funcs $ runErrorT $ buildStructuredP ONone s id + = do res <- flip runStateT (0, 0, ([],[]), []) $ flip runReaderT funcs $ runErrorT $ buildStructuredSeq s id return $ case res of (Left err,_) -> Left err - (Right (Left {}),(_,_,(nodes, edges),roots)) -> Right (mkGraph nodes edges, roots) - (Right (Right (root,_)),(_,_,(nodes, edges),roots)) -> Right (mkGraph nodes edges, root : roots) + (Right (root,_),(_,_,(nodes, edges),roots)) -> Right (mkGraph nodes edges, root : roots) decomp22 :: (Monad m, Data a, Typeable a0, Typeable a1) => (a0 -> a1 -> a) -> (a1 -> m a1) -> (a -> m a) diff --git a/common/FlowGraphTest.hs b/common/FlowGraphTest.hs index 2bf768c..1b43140 100644 --- a/common/FlowGraphTest.hs +++ b/common/FlowGraphTest.hs @@ -108,26 +108,27 @@ nextId' inc t -- for being isomorphic, based on the meta-tag node labels (node E in the expected list is -- isomorphic to node A in the actual list if their meta tags are the same). testGraph :: String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.Process -> Test -testGraph testName nodes roots edges proc = testGraph' testName nodes roots edges (A.Only emptyMeta proc) +testGraph testName nodes roots edges proc = testGraphF testName nodes roots edges (buildFlowGraphP testOps $ A.Only emptyMeta proc) ---TODO test root nodes too +testGraph' :: String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.AST -> Test +testGraph' testName nodes roots edges str = testGraphF testName nodes roots edges (buildFlowGraph testOps str) -testGraph' :: String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.Structured A.Process -> Test -testGraph' testName nodes roots edges code +testOps :: GraphLabelFuncs (State (Map.Map Meta Int)) Int +testOps = GLF nextId nextId nextId nextId nextId nextId (nextId' 100) (nextId' 100) + +testGraphF :: Data structType => String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> State (Map.Map Meta Int) (Either String (FlowGraph' Identity Int structType, [Node])) -> Test +testGraphF testName nodes roots edges grF = TestCase $ - case evalState (buildFlowGraphP testOps code) Map.empty of + case evalState grF Map.empty of Left err -> assertFailure (testName ++ " graph building failed: " ++ err) - Right gr -> checkGraphEquality (nodes, roots, edges) (gr :: (FlowGraph' Identity Int A.Process, [Node])) + Right gr -> checkGraphEquality (nodes, roots, edges) gr -- :: (FlowGraph' Identity Int structType, [Node])) where -- Checks two graphs are equal by creating a node mapping from the expected graph to the real map (checkNodeEquality), -- then mapping the edges across (transformEdge) and checking everything is right (in checkGraphEquality) -- deNode :: Monad m => FNode' m a b -> (Meta, a) deNode nd = (getNodeMeta nd, getNodeData nd) - - testOps :: GraphLabelFuncs (State (Map.Map Meta Int)) Int - testOps = GLF nextId nextId nextId nextId nextId nextId (nextId' 100) (nextId' 100) - + checkGraphEquality :: (Data a, Monad m) => ([(Int, Meta)], [Int], [(Int, Int, EdgeLabel)]) -> (FlowGraph' m Int a, [Int]) -> Assertion checkGraphEquality (nodes, roots, edges) (g, actRoots) = do let (remainingNodes, nodeLookup, ass) = foldl checkNodeEquality (Map.fromList (map revPair nodes),Map.empty, return ()) (map (transformPair id deNode) $ labNodes g) @@ -164,7 +165,7 @@ someSpec m = A.Specification m (simpleName $ show m) (A.DataType m A.Int) testSeq :: Test testSeq = TestLabel "testSeq" $ TestList [ - testSeq' 0 [(0,m0)] [] (A.Several m1 []) + testSeq' 0 [(0,m1)] [] (A.Several m1 []) ,testSeq' 1 [(0,m2)] [] (A.Only m1 sm2) ,testSeq' 2 [(0,m3)] [] (A.Several m1 [A.Only m2 sm3]) ,testSeq' 3 [(0,m3),(1,m5)] [(0,1,ESeq)] (A.Several m1 [A.Only m2 sm3,A.Only m4 sm5]) @@ -179,7 +180,7 @@ testSeq = TestLabel "testSeq" $ TestList [(1,3,ESeq),(3,101,ESeq),(101,5,ESeq),(5,7,ESeq),(7,9,ESeq),(9,107,ESeq),(107,105,ESeq)] (A.Several m11 [A.Spec mU (someSpec m1) $ A.Only m3 sm4,A.Spec mU (someSpec m5) $ A.Spec mU (someSpec m7) $ A.Only m9 sm10]) - ,testSeq' 12 [(0,m1),(100,sub m1 100)] [(0,100,ESeq)] (A.Spec mU (someSpec m1) $ A.Several m4 []) + ,testSeq' 12 [(0,m1),(4,m4),(100,sub m1 100)] [(0,4,ESeq),(4,100,ESeq)] (A.Spec mU (someSpec m1) $ A.Several m4 []) -- Replicated SEQ: @@ -192,11 +193,11 @@ testSeq = TestLabel "testSeq" $ TestList ,(A.Rep m8 (A.For m8 undefined undefined undefined) $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5]) ,A.Only mU sm11]) - ,testSeq' 102 [(0,m10)] [(0,0,ESeq)] - (A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several mU []) + ,testSeq' 102 [(0,m10), (1,m1)] [(0,1,ESeq), (1,0,ESeq)] + (A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several m1 []) - ,testSeq' 103 [(1,m10), (0,m1), (2,m2)] [(0,1,ESeq),(1,1,ESeq),(1,2,ESeq)] - (A.Several mU [A.Only mU sm1, (A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several mU []), A.Only mU sm2]) + ,testSeq' 103 [(1,m10), (0,m1), (2,m2), (3,m3)] [(0,1,ESeq),(1,3,ESeq), (3,1,ESeq),(1,2,ESeq)] + (A.Several mU [A.Only mU sm1, (A.Rep m10 (A.For m10 undefined undefined undefined) $ A.Several m3 []), A.Only mU sm2]) ] where @@ -283,13 +284,13 @@ testCase = TestLabel "testCase" $ TestList [ testGraph "testCase 0" [(0,m10),(1,m0),(2,m3)] [0] [(0,2,ESeq),(2,1,ESeq)] (A.Case m0 (A.True m10) $ cases m1 [A.Else m2 sm3]) ,testGraph "testCase 1" - [(0,m10),(1,m0),(3,m3)] [0] - [(0,3,ESeq),(3,1,ESeq)] - (A.Case m0 (A.True m10) $ cases m1 [A.Option mU [A.True mU] sm3]) + [(0,m10),(1,m0),(2,m2),(3,m3)] [0] + [(0,2,ESeq),(2,3,ESeq),(3,1,ESeq)] + (A.Case m0 (A.True m10) $ cases mU [A.Option mU [A.True m2] sm3]) ,testGraph "testCase 2" - [(0,m10),(1,m0),(3,m3),(5,m5)] [0] - [(0,3,ESeq), (3,1,ESeq), (0,5,ESeq), (5,1,ESeq)] - (A.Case m0 (A.True m10) $ cases m1 [A.Option mU [A.True mU] sm3, A.Option mU [A.True mU] sm5]) + [(0,m10),(1,m0), (2,m2), (3,m3), (4, m4), (5,m5)] [0] + [(0,2,ESeq), (2,3,ESeq), (3,1,ESeq), (0,4,ESeq), (4,5,ESeq), (5,1,ESeq)] + (A.Case m0 (A.True m10) $ cases m1 [A.Option mU [A.True m2] sm3, A.Option mU [A.True m4] sm5]) --TODO test case statements that have specs ] where @@ -332,17 +333,18 @@ testIf = TestLabel "testIf" $ TestList testProcFuncSpec :: Test testProcFuncSpec = TestLabel "testProcFuncSpec" $ TestList [ - -- Single spec of process (with SKIP body): - testGraph' "testProcFuncSpec 0" [(0, m0),(1,m1),(2,sub m1 100), (5,m5)] [1,5] [(5,0,ESeq), (1,2,ESeq)] + -- Single spec of process (with SKIP body) in AST (not connected up): + testGraph' "testProcFuncSpec 0" [(0, m0), (5,m5)] [5] [(5,0,ESeq)] (A.Spec mU (A.Specification m1 undefined $ A.Proc m5 undefined undefined sm0) $ A.Several mU []) + -- Single spec of process (with body with SEQ SKIP SKIP): - ,testGraph' "testProcFuncSpec 1" [(0, m3),(1,m6),(2,sub m6 100),(4,m5), (9,m9)] [1,9] ([(1,2,ESeq)] ++ [(9,0,ESeq), (0,4,ESeq)]) + ,testGraph' "testProcFuncSpec 1" [(0, m3), (4,m5), (9,m9)] [9] ([(9,0,ESeq), (0,4,ESeq)]) (A.Spec mU (A.Specification m6 undefined $ A.Proc m9 undefined undefined $ A.Seq m0 $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5] ) $ A.Several mU []) -- Nested spec of process (with bodies with SEQ SKIP SKIP): - ,testGraph' "testProcFuncSpec 2" [(0,m6),(1,sub m6 100),(3,m2),(4,m3),(5,m4),(6,m5),(7,m7),(8,sub m7 100), (10,m10), (11, m11)] [0,10,11] - ([(0,7,ESeq), (7,8,ESeq), (8,1,ESeq)] ++ [(10,3,ESeq), (3,4,ESeq)] ++ [(11,5,ESeq), (5,6,ESeq)]) + ,testGraph' "testProcFuncSpec 2" [(3,m2),(4,m3),(5,m4),(6,m5), (10,m10), (11, m11)] [10,11] + ([(10,3,ESeq), (3,4,ESeq)] ++ [(11,5,ESeq), (5,6,ESeq)]) (A.Spec mU (A.Specification m6 undefined $ A.Proc m10 undefined undefined $ A.Seq mU $ A.Several mU [A.Only mU sm2,A.Only mU sm3] ) $ @@ -350,6 +352,11 @@ testProcFuncSpec = TestLabel "testProcFuncSpec" $ TestList A.Seq mU $ A.Several mU [A.Only mU sm4,A.Only mU sm5] ) $ A.Several mU []) + + -- Single spec of process (with SKIP body) in a SEQ (connected up): + ,testGraph "testProcFuncSpec 10" [(0, m0),(1,m1),(2,sub m1 100), (3, m3), (5,m5)] [1,5] [(5,0,ESeq), (1,3,ESeq), (3,2,ESeq)] + (A.Seq mU $ A.Spec mU (A.Specification m1 undefined $ A.Proc m5 undefined undefined sm0) $ A.Several m3 []) + ] --TODO test replicated seq/par