Changed the identifiers/values on graph nodes in the control-flow graph to be produced monadically, and altered the tests accordingly
This commit is contained in:
parent
8fa046798a
commit
9b1cd56050
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user