From 9b1cd560509786f72e684fa5cb60fdca8e8bdc4d Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sat, 27 Oct 2007 23:59:33 +0000 Subject: [PATCH] Changed the identifiers/values on graph nodes in the control-flow graph to be produced monadically, and altered the tests accordingly --- common/FlowGraph.hs | 42 +++++++++++++++++++++++++---------------- common/FlowGraphTest.hs | 28 +++++++++++++++++++++++---- 2 files changed, 50 insertions(+), 20 deletions(-) diff --git a/common/FlowGraph.hs b/common/FlowGraph.hs index 6834d28..1c2af40 100644 --- a/common/FlowGraph.hs +++ b/common/FlowGraph.hs @@ -38,32 +38,36 @@ type FlowGraph a = Gr (FNode a) EdgeLabel type NodesEdges a = ([LNode (FNode a)],[LEdge EdgeLabel]) -type GraphMaker a b = ErrorT String (State (Node, NodesEdges a)) b +type GraphMaker m a b = ErrorT String (StateT (Node, NodesEdges a) m) b -buildFlowGraph :: a -> (forall t. Data t => t -> a) -> A.Structured -> Either String (FlowGraph a) -buildFlowGraph blank f s = case runState (runErrorT $ buildStructured None s) (0, ([],[]) ) of - (Left err,_) -> Left err - (_,(_,(nodes, edges))) -> Right (mkGraph nodes edges) +-- 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, ([],[]) ) + return $ case res of + (Left err,_) -> Left err + (_,(_,(nodes, edges))) -> Right (mkGraph nodes edges) where -- All the functions return the new graph, and the identifier of the node just added - addNode :: FNode a -> GraphMaker a Node + addNode :: Monad m => FNode a -> GraphMaker m a Node addNode x = do (n,(nodes, edges)) <- get put (n+1, ((n, x):nodes, edges)) return n - addEdge :: EdgeLabel -> Node -> Node -> GraphMaker a () + 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)) -- Type commented out because it's not technically correct, but looks right to me: --- addDummyNode :: Meta -> GraphMaker a Node - addDummyNode m = addNode (m, blank) +-- addDummyNode :: Meta -> GraphMaker m a Node + addDummyNode m = do val <- (lift . lift) (blank m) + addNode (m, val) -- 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 a (Node, Node) +-- buildStructured :: OuterType -> A.Structured -> GraphMaker m a (Node, Node) buildStructured outer (A.Several m ss) = do nodes <- mapM (buildStructured outer) ss case outer of @@ -73,14 +77,20 @@ buildFlowGraph blank f s = case runState (runErrorT $ buildStructured None s) (0 [] -> do n <- addDummyNode m return (n,n) _ -> return (fst (head nodes), snd (last nodes)) - Par -> do nStart <- addDummyNode m - nEnd <- addDummyNode m - mapM (\(a,z) -> addEdge EPar nStart a >> addEdge ESeq z nEnd) nodes - return (nStart, nEnd) + Par -> do case nodes of + [] -> do n <- addDummyNode m + return (n,n) + [(s,e)] -> return (s,e) + _ -> do + nStart <- addDummyNode m + nEnd <- addDummyNode m + mapM (\(a,z) -> addEdge EPar nStart a >> addEdge ESeq z nEnd) nodes + return (nStart, nEnd) buildStructured _ (A.OnlyP _ p) = buildProcess p -- Type commented out because it's not technically correct, but looks right to me: --- buildProcess :: A.Process -> GraphMaker a (Node, Node) +-- buildProcess :: A.Process -> GraphMaker m a (Node, Node) buildProcess (A.Seq _ s) = buildStructured Seq s buildProcess (A.Par _ _ s) = buildStructured Par s - buildProcess p@(A.Skip m) = (liftM mkPair) $ addNode (m, f p) + buildProcess p@(A.Skip m) = do val <- (lift . lift) (f p) + (liftM mkPair) $ addNode (m, val) diff --git a/common/FlowGraphTest.hs b/common/FlowGraphTest.hs index 4387113..7685d3b 100644 --- a/common/FlowGraphTest.hs +++ b/common/FlowGraphTest.hs @@ -18,6 +18,8 @@ with this program. If not, see . module FlowGraphTest (tests) where +import Control.Monad.State + import Data.Generics import Data.Graph.Inductive import Data.List @@ -31,7 +33,7 @@ import Metadata import Utils makeMeta :: Int -> Meta -makeMeta n = Meta (Just "FlowGraphTest") n n +makeMeta n = Meta (Just "FlowGraphTest") n 0 -- To make typing the tests as short as possible: m0 = makeMeta 0 @@ -39,20 +41,38 @@ m1 = makeMeta 1 m2 = makeMeta 2 m3 = makeMeta 3 m4 = makeMeta 4 +m5 = makeMeta 5 +m6 = makeMeta 6 +m7 = makeMeta 7 + +sub :: Meta -> Int -> Meta +sub m n = m {metaColumn = n} sm0 = A.Skip m0 sm1 = A.Skip m1 sm2 = A.Skip m2 sm3 = A.Skip m3 sm4 = A.Skip m4 +sm5 = A.Skip m5 +sm6 = A.Skip m6 +sm7 = A.Skip m7 -showGraph :: Graph g => g a b -> String -showGraph g = " Nodes: " ++ show (nodes g) ++ " Edges: " ++ show (edges g) +showGraph :: (Graph g, Show a, Show b) => g a b -> String +showGraph g = " Nodes: " ++ show (labNodes g) ++ " Edges: " ++ show (labEdges g) + +nextId :: Data t => t -> State (Map.Map Meta Int) Int +nextId t = do mp <- get + case Map.lookup m mp of + Just n -> do put $ Map.adjust ((+) 1) m mp + return n + Nothing -> do put $ Map.insert m 1 mp + return 0 + where m = findMeta t testGraph :: String -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Process -> Test testGraph testName nodes edges proc = TestCase $ - case buildFlowGraph () (const ()) (A.OnlyP emptyMeta proc) of + case evalState (buildFlowGraph nextId nextId (A.OnlyP emptyMeta proc)) Map.empty of Left err -> assertFailure (testName ++ " graph building failed: " ++ err) Right g -> checkGraphEquality (nodes, edges) g where