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

Changed the identifiers/values on graph nodes in the control-flow graph to be produced monadically, and altered the tests accordingly

Browse Source
This commit is contained in:
Neil Brown 2007-10-27 23:59:33 +00:00
parent 8fa046798a
commit 9b1cd56050
2 changed files with 50 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
common/FlowGraph.hs
View File

@ -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)

28
common/FlowGraphTest.hs
View File

@ -18,6 +18,8 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
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