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

Rearranged FlowGraph and fixed the tests

Browse Source 
Previously, most of the flow-graph building functions were inside the where clause of buildFlowGraph.  They have been moved to the top-level (with only a few small changes to make this possible - the main one being to store the labelling functions in a reader monad, which only required changing a couple of lines) and used by an additional buildFlowGraphP function, that is now used by the tests to make them work simply.  None of the new top-level functions except buildFlowGraphP are exported from FlowGraph.
This commit is contained in:
Neil Brown 2008-02-05 22:04:49 +00:00
parent acd57d74de
commit fa1e9a6a08
2 changed files with 290 additions and 267 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

183
common/FlowGraph.hs
View File

@ -41,12 +41,13 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- * If statements, on the other hand, have to be chained together. Each expression is connected -- * If statements, on the other hand, have to be chained together. Each expression is connected
-- to its body, but also to the next expression. There is no link between the last expression -- to its body, but also to the next expression. There is no link between the last expression
-- and the end of the if; if statements behave like STOP if nothing is matched. -- and the end of the if; if statements behave like STOP if nothing is matched.
module FlowGraph (AlterAST(..), EdgeLabel(..), FNode, FlowGraph, FlowGraph', GraphLabelFuncs(..), buildFlowGraph, getNodeData, getNodeFunc, getNodeMeta, joinLabelFuncs, makeFlowGraphInstr, makeTestNode, mkLabelFuncsConst, mkLabelFuncsGeneric) where module FlowGraph (AlterAST(..), EdgeLabel(..), FNode, FlowGraph, FlowGraph', GraphLabelFuncs(..), buildFlowGraph, buildFlowGraphP, getNodeData, getNodeFunc, getNodeMeta, joinLabelFuncs, makeFlowGraphInstr, makeTestNode, mkLabelFuncsConst, mkLabelFuncsGeneric) where
import Control.Monad.Error import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State import Control.Monad.State
import Data.Generics import Data.Generics
import Data.Graph.Inductive import Data.Graph.Inductive hiding (run)
import qualified AST as A import qualified AST as A
import Metadata import Metadata
@ -114,7 +115,7 @@ type NodesEdges m a b = ([LNode (FNode' m a b)],[LEdge EdgeLabel])
-- * The list of root nodes thus far (those with no links to them) -- * The list of root nodes thus far (those with no links to them)
type GraphMakerState mAlter a b = (Node, Int, NodesEdges mAlter a b, [Node]) type GraphMakerState mAlter a b = (Node, Int, NodesEdges mAlter a b, [Node])
type GraphMaker mLabel mAlter a b c = ErrorT String (StateT (GraphMakerState mAlter a b) mLabel) c type GraphMaker mLabel mAlter a b c = ErrorT String (ReaderT (GraphLabelFuncs mLabel a) (StateT (GraphMakerState mAlter a b) mLabel)) c
-- | The GraphLabelFuncs type. These are a group of functions -- | The GraphLabelFuncs type. These are a group of functions
-- used to provide labels for different elements of AST. -- used to provide labels for different elements of AST.
@ -178,93 +179,77 @@ mkLabelFuncsConst v = GLF (const v) (const v) (const v) (const v) (const v) (con
mkLabelFuncsGeneric :: Monad m => (forall t. Data t => t -> m label) -> GraphLabelFuncs m label mkLabelFuncsGeneric :: Monad m => (forall t. Data t => t -> m label) -> GraphLabelFuncs m label
mkLabelFuncsGeneric f = GLF f f f f f f f f mkLabelFuncsGeneric f = GLF f f f f f f f f
-- | Builds a control-flow-graph. The mAlter monad is the monad in which
-- AST alterations would take place. Note that mAlter does not feature in
-- 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) =>
GraphLabelFuncs mLabel label ->
A.Structured structType ->
mLabel (Either String (FlowGraph' mAlter label structType, [Node]))
buildFlowGraph funcs s
= do res <- runStateT (runErrorT $ buildStructured (\_ _ _ -> throwError "Did not expect outer-most node to exist in AST") ONone s id) (0, 0, ([],[]), [])
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)
where
-- All the functions return the new graph, and the identifier of the node just added
run :: (GraphLabelFuncs mLabel label -> (b -> mLabel label)) -> b -> mLabel label run :: forall mLabel mAlter label structType b. (Monad mLabel, Monad mAlter) => (GraphLabelFuncs mLabel label -> (b -> mLabel label)) -> b -> GraphMaker mLabel mAlter label structType label
run func = func funcs run func x = do f <- asks func
lift . lift .lift $ f x
addNode :: (Meta, label, AlterAST mAlter structType) -> GraphMaker mLabel mAlter label structType Node addNode :: (Monad mLabel, Monad mAlter) => (Meta, label, AlterAST mAlter structType) -> GraphMaker mLabel mAlter label structType Node
addNode x = do (n,pi,(nodes, edges), rs) <- get addNode x = do (n,pi,(nodes, edges), rs) <- get
put (n+1, pi,((n, Node x):nodes, edges), rs) put (n+1, pi,((n, Node x):nodes, edges), rs)
return n return n
denoteRootNode :: Node -> GraphMaker mLabel mAlter label structType () denoteRootNode :: (Monad mLabel, Monad mAlter) => Node -> GraphMaker mLabel mAlter label structType ()
denoteRootNode root = do (n, pi, nes, roots) <- get denoteRootNode root = do (n, pi, nes, roots) <- get
put (n, pi, nes, root : roots) put (n, pi, nes, root : roots)
addEdge :: EdgeLabel -> Node -> Node -> GraphMaker mLabel mAlter label structType () addEdge :: (Monad mLabel, Monad mAlter) => EdgeLabel -> Node -> Node -> GraphMaker mLabel mAlter label structType ()
addEdge label start end = do (n, pi, (nodes, edges), rs) <- get addEdge label start end = do (n, pi, (nodes, edges), rs) <- get
-- Edges should only be added after the nodes, so -- Edges should only be added after the nodes, so
-- for safety here we can check that the nodes exist: -- for safety here we can check that the nodes exist:
if (notElem start $ map fst nodes) || (notElem end $ map fst nodes) if (notElem start $ map fst nodes) || (notElem end $ map fst nodes)
then throwError "Could not add edge between non-existent nodes" then throwError "Could not add edge between non-existent nodes"
else put (n + 1, pi, (nodes,(start, end, label):edges), rs) else put (n + 1, pi, (nodes,(start, end, label):edges), rs)
-- It is important for the flow-graph tests that the Meta tag passed in is the same as the -- It is important for the flow-graph tests that the Meta tag passed in is the same as the
-- result of calling findMeta on the third parameter -- result of calling findMeta on the third parameter
addNode' :: Meta -> (GraphLabelFuncs mLabel label -> (b -> mLabel label)) -> b -> AlterAST mAlter structType -> GraphMaker mLabel mAlter label structType Node addNode' :: (Monad mLabel, Monad mAlter) => Meta -> (GraphLabelFuncs mLabel label -> (b -> mLabel label)) -> b -> AlterAST mAlter structType -> GraphMaker mLabel mAlter label structType Node
addNode' m f t r = do val <- (lift . lift) (run f t) addNode' m f t r = do val <- run f t
addNode (m, val, r) addNode (m, val, r)
addNodeExpression :: Meta -> A.Expression -> (ASTModifier mAlter A.Expression structType) -> GraphMaker mLabel mAlter label structType Node addNodeExpression :: (Monad mLabel, Monad mAlter) => Meta -> A.Expression -> (ASTModifier mAlter A.Expression structType) -> GraphMaker mLabel mAlter label structType Node
addNodeExpression m e r = addNode' m labelExpression e (AlterExpression r) addNodeExpression m e r = addNode' m labelExpression e (AlterExpression r)
addNodeExpressionList :: Meta -> A.ExpressionList -> (ASTModifier mAlter A.ExpressionList structType) -> GraphMaker mLabel mAlter label structType Node addNodeExpressionList :: (Monad mLabel, Monad mAlter) => Meta -> A.ExpressionList -> (ASTModifier mAlter A.ExpressionList structType) -> GraphMaker mLabel mAlter label structType Node
addNodeExpressionList m e r = addNode' m labelExpressionList e (AlterExpressionList r) addNodeExpressionList m e r = addNode' m labelExpressionList e (AlterExpressionList r)
addDummyNode :: Meta -> GraphMaker mLabel mAlter label structType Node addDummyNode :: (Monad mLabel, Monad mAlter) => Meta -> GraphMaker mLabel mAlter label structType Node
addDummyNode m = addNode' m labelDummy m AlterNothing addDummyNode m = addNode' m labelDummy m AlterNothing
getNextParEdgeId :: GraphMaker mLabel mAlter label structType Int getNextParEdgeId :: (Monad mLabel, Monad mAlter) => GraphMaker mLabel mAlter label structType Int
getNextParEdgeId = do (a, pi, b, c) <- get getNextParEdgeId = do (a, pi, b, c) <- get
put (a, pi + 1, b, c) put (a, pi + 1, b, c)
return pi return pi
addParEdges :: Int -> (Node,Node) -> [(Node,Node)] -> GraphMaker mLabel mAlter label structType () addParEdges :: (Monad mLabel, Monad mAlter) => Int -> (Node,Node) -> [(Node,Node)] -> GraphMaker mLabel mAlter label structType ()
addParEdges usePI (s,e) pairs addParEdges usePI (s,e) pairs
= do (n,pi,(nodes,edges),rs) <- get = do (n,pi,(nodes,edges),rs) <- get
put (n,pi,(nodes,edges ++ (concatMap (parEdge usePI) pairs)),rs) put (n,pi,(nodes,edges ++ (concatMap (parEdge usePI) pairs)),rs)
where where
parEdge :: Int -> (Node, Node) -> [LEdge EdgeLabel] parEdge :: Int -> (Node, Node) -> [LEdge EdgeLabel]
parEdge id (a,z) = [(s,a,(EStartPar id)),(z,e,(EEndPar id))] parEdge id (a,z) = [(s,a,(EStartPar id)),(z,e,(EEndPar id))]
-- The build-up functions are all of type (innerType -> m innerType) -> outerType -> m outerType -- The build-up functions are all of type (innerType -> m innerType) -> outerType -> m outerType
-- which has the synonym Route m innerType outerType -- which has the synonym Route m innerType outerType
getN :: Int -> [a] -> ([a],a,[a]) getN :: Int -> [a] -> ([a],a,[a])
getN n xs = let (f,(m:e)) = splitAt n xs in (f,m,e) getN n xs = let (f,(m:e)) = splitAt n xs in (f,m,e)
routeList :: Monad m => Int -> (a -> m a) -> ([a] -> m [a]) routeList :: Monad m => Int -> (a -> m a) -> ([a] -> m [a])
routeList n f xs routeList n f xs
= do let (pre,x,suf) = getN n xs = do let (pre,x,suf) = getN n xs
x' <- f x x' <- f x
return (pre ++ [x'] ++ suf) return (pre ++ [x'] ++ suf)
mapMR :: forall inner. 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 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 outerRoute func xs = mapM funcAndRoute (zip [0..] xs) mapMR outerRoute func xs = mapM funcAndRoute (zip [0..] xs)
where where
funcAndRoute :: (Int, inner) -> GraphMaker mLabel mAlter label structType (Node,Node) funcAndRoute :: (Int, inner) -> GraphMaker mLabel mAlter label structType (Node,Node)
funcAndRoute (ind,x) = func x (outerRoute @-> routeList ind) funcAndRoute (ind,x) = func x (outerRoute @-> routeList ind)
mapMRE :: forall inner. ASTModifier mAlter [inner] structType -> (inner -> ASTModifier mAlter inner structType -> GraphMaker mLabel mAlter label structType (Either Bool (Node,Node))) -> [inner] -> GraphMaker mLabel mAlter label structType (Either Bool [(Node,Node)]) mapMRE :: forall inner mAlter mLabel label structType. (Monad mLabel, Monad mAlter) => ASTModifier mAlter [inner] structType -> (inner -> ASTModifier mAlter inner structType -> GraphMaker mLabel mAlter label structType (Either Bool (Node,Node))) -> [inner] -> GraphMaker mLabel mAlter label structType (Either Bool [(Node,Node)])
mapMRE outerRoute func xs = mapM funcAndRoute (zip [0..] xs) >>* foldl foldEither (Left False) mapMRE outerRoute func xs = mapM funcAndRoute (zip [0..] xs) >>* foldl foldEither (Left False)
where where
foldEither :: Either Bool [(Node,Node)] -> Either Bool (Node,Node) -> Either Bool [(Node,Node)] foldEither :: Either Bool [(Node,Node)] -> Either Bool (Node,Node) -> Either Bool [(Node,Node)]
foldEither (Left _) (Right n) = Right [n] foldEither (Left _) (Right n) = Right [n]
@ -276,25 +261,32 @@ buildFlowGraph funcs s
funcAndRoute (ind,x) = func x (outerRoute @-> routeList ind) funcAndRoute (ind,x) = func x (outerRoute @-> routeList ind)
nonEmpty :: Either Bool [(Node,Node)] -> Bool nonEmpty :: Either Bool [(Node,Node)] -> Bool
nonEmpty (Left hadNodes) = hadNodes nonEmpty (Left hadNodes) = hadNodes
nonEmpty (Right nodes) = not (null nodes) nonEmpty (Right nodes) = not (null nodes)
joinPairs :: Meta -> [(Node, Node)] -> GraphMaker mLabel mAlter label structType (Node, Node) joinPairs :: (Monad mLabel, Monad mAlter) => Meta -> [(Node, Node)] -> GraphMaker mLabel mAlter label structType (Node, Node)
joinPairs m [] = addDummyNode m >>* mkPair joinPairs m [] = addDummyNode m >>* mkPair
joinPairs m nodes = do sequence_ $ mapPairs (\(_,s) (e,_) -> addEdge ESeq s e) nodes joinPairs m nodes = do sequence_ $ mapPairs (\(_,s) (e,_) -> addEdge ESeq s e) nodes
return (fst (head nodes), snd (last nodes)) return (fst (head nodes), snd (last nodes))
buildStructuredP = buildStructured (\_ r p -> buildProcess p r) buildStructuredP :: (Monad mLabel, Monad mAlter) =>
buildStructuredC = buildStructured buildOnlyChoice OuterType -> A.Structured A.Process -> ASTModifier mAlter (A.Structured A.Process) structType -> GraphMaker mLabel mAlter label structType (Either Bool (Node, Node))
buildStructuredO = buildStructured buildOnlyOption 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 -- Returns a pair of beginning-node, end-node
-- Bool indicates emptiness (False = empty, True = there was something) -- Bool indicates emptiness (False = empty, True = there was something)
buildStructured :: forall a. Data a => (OuterType -> ASTModifier mAlter a structType -> a -> GraphMaker mLabel mAlter label structType (Node, Node)) -> 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)) 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 buildStructured f outer (A.Several m ss) route
= do case outer of = do case outer of
ONone -> -- If there is no context, they should be left as disconnected graphs. ONone -> -- If there is no context, they should be left as disconnected graphs.
do nodes <- mapMRE decompSeveral (buildStructured f outer) ss do nodes <- mapMRE decompSeveral (buildStructured f outer) ss
@ -322,7 +314,7 @@ buildFlowGraph funcs s
decompSeveral :: ASTModifier mAlter [A.Structured a] structType decompSeveral :: ASTModifier mAlter [A.Structured a] structType
decompSeveral = route22 route A.Several decompSeveral = route22 route A.Several
buildStructured f outer (A.Spec m spec str) route buildStructured f outer (A.Spec m spec str) route
= do n <- addNode' (findMeta spec) labelScopeIn spec (AlterSpec $ route23 route A.Spec) = do n <- addNode' (findMeta spec) labelScopeIn spec (AlterSpec $ route23 route A.Spec)
n' <- addNode' (findMeta spec) labelScopeOut spec (AlterSpec $ route23 route A.Spec) n' <- addNode' (findMeta spec) labelScopeOut spec (AlterSpec $ route23 route A.Spec)
@ -347,7 +339,7 @@ buildFlowGraph funcs s
Right (s,e) -> do addEdge ESeq n s Right (s,e) -> do addEdge ESeq n s
addEdge ESeq e n' addEdge ESeq e n'
return $ Right (n,n') return $ Right (n,n')
buildStructured f outer (A.Rep m rep str) route buildStructured f outer (A.Rep m rep str) route
= do let alter = AlterReplicator $ route23 route A.Rep = do let alter = AlterReplicator $ route23 route A.Rep
case outer of case outer of
OSeq -> do n <- addNode' (findMeta rep) labelReplicator rep alter OSeq -> do n <- addNode' (findMeta rep) labelReplicator rep alter
@ -372,10 +364,10 @@ buildFlowGraph funcs s
return $ Right (s,e) return $ Right (s,e)
_ -> throwError $ "Cannot have replicators inside context: " ++ show outer _ -> throwError $ "Cannot have replicators inside context: " ++ show outer
buildStructured f outer (A.Only _ o) route = f outer (route22 route A.Only) o >>* Right buildStructured f outer (A.Only _ o) route = f outer (route22 route A.Only) o >>* Right
buildStructured _ _ s _ = return $ Left False buildStructured _ _ s _ = return $ Left False
buildOnlyChoice outer route (A.Choice m exp p) buildOnlyChoice outer route (A.Choice m exp p)
= do nexp <- addNodeExpression (findMeta exp) exp $ route23 route A.Choice = do nexp <- addNodeExpression (findMeta exp) exp $ route23 route A.Choice
(nbodys, nbodye) <- buildProcess p $ route33 route A.Choice (nbodys, nbodye) <- buildProcess p $ route33 route A.Choice
addEdge ESeq nexp nbodys addEdge ESeq nexp nbodys
@ -385,7 +377,7 @@ buildFlowGraph funcs s
addEdge ESeq nbodye cEnd addEdge ESeq nbodye cEnd
_ -> throwError "Choice found outside IF statement" _ -> throwError "Choice found outside IF statement"
return (nexp,nbodye) return (nexp,nbodye)
buildOnlyOption outer route opt buildOnlyOption outer route opt
= do (s,e) <- = do (s,e) <-
case opt of case opt of
(A.Option m es p) -> do (A.Option m es p) -> do
@ -402,9 +394,10 @@ buildFlowGraph funcs s
_ -> throwError "Option found outside CASE statement" _ -> throwError "Option found outside CASE statement"
return (s,e) return (s,e)
addNewSubProcFunc :: Meta -> [A.Formal] -> Either (A.Process, ASTModifier mAlter A.Process structType) (A.Structured A.ExpressionList, ASTModifier mAlter (A.Structured A.ExpressionList) structType) -> 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) ->
ASTModifier mAlter [A.Formal] structType -> GraphMaker mLabel mAlter label structType () ASTModifier mAlter [A.Formal] structType -> GraphMaker mLabel mAlter label structType ()
addNewSubProcFunc m args body argsRoute addNewSubProcFunc m args body argsRoute
= do root <- addNode' m labelStartNode (m, args) (AlterArguments argsRoute) = do root <- addNode' m labelStartNode (m, args) (AlterArguments argsRoute)
denoteRootNode root denoteRootNode root
bodyNode <- case body of bodyNode <- case body of
@ -418,15 +411,15 @@ buildFlowGraph funcs s
where where
buildEL m _ r el = addNodeExpressionList m el r >>* mkPair buildEL m _ r el = addNodeExpressionList m el r >>* mkPair
buildProcess :: A.Process -> ASTModifier mAlter A.Process structType -> GraphMaker mLabel mAlter label structType (Node, Node) 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 buildProcess (A.Seq m s) route
= do s <- buildStructuredP OSeq s (route22 route A.Seq) = do s <- buildStructuredP OSeq s (route22 route A.Seq)
case s of case s of
Left True -> throwError $ show m ++ " SEQ had non-joined up body when building flow-graph" Left True -> throwError $ show m ++ " SEQ had non-joined up body when building flow-graph"
Left False -> do n <- addDummyNode m Left False -> do n <- addDummyNode m
return (n, n) return (n, n)
Right ns -> return ns Right ns -> return ns
buildProcess (A.Par m _ s) route buildProcess (A.Par m _ s) route
= do nStart <- addDummyNode m = do nStart <- addDummyNode m
nEnd <- addDummyNode m nEnd <- addDummyNode m
pId <- getNextParEdgeId pId <- getNextParEdgeId
@ -438,23 +431,53 @@ buildFlowGraph funcs s
do addEdge (EStartPar pId) nStart start do addEdge (EStartPar pId) nStart start
addEdge (EEndPar pId) end nEnd addEdge (EEndPar pId) end nEnd
return (nStart, nEnd) return (nStart, nEnd)
buildProcess (A.While _ e p) route buildProcess (A.While _ e p) route
= do n <- addNodeExpression (findMeta e) e (route23 route A.While) = do n <- addNodeExpression (findMeta e) e (route23 route A.While)
(start, end) <- buildProcess p (route33 route A.While) (start, end) <- buildProcess p (route33 route A.While)
addEdge ESeq n start addEdge ESeq n start
addEdge ESeq end n addEdge ESeq end n
return (n, n) return (n, n)
buildProcess (A.Case m e s) route buildProcess (A.Case m e s) route
= do nStart <- addNodeExpression (findMeta e) e (route23 route A.Case) = do nStart <- addNodeExpression (findMeta e) e (route23 route A.Case)
nEnd <- addDummyNode m nEnd <- addDummyNode m
buildStructuredO (OCase (nStart,nEnd)) s (route33 route A.Case) buildStructuredO (OCase (nStart,nEnd)) s (route33 route A.Case)
return (nStart, nEnd) return (nStart, nEnd)
buildProcess (A.If m s) route buildProcess (A.If m s) route
= do nStart <- addDummyNode m = do nStart <- addDummyNode m
nEnd <- addDummyNode m nEnd <- addDummyNode m
buildStructuredC (OIf nStart nEnd) s (route22 route A.If) buildStructuredC (OIf nStart nEnd) s (route22 route A.If)
return (nStart, nEnd) return (nStart, nEnd)
buildProcess p route = addNode' (findMeta p) labelProcess p (AlterProcess route) >>* mkPair buildProcess p route = addNode' (findMeta p) labelProcess p (AlterProcess route) >>* mkPair
-- | Builds a control-flow-graph. The mAlter monad is the monad in which
-- AST alterations would take place. Note that mAlter does not feature in
-- 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) =>
GraphLabelFuncs mLabel label ->
A.Structured structType ->
mLabel (Either String (FlowGraph' mAlter label structType, [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
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)
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
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)
decomp22 :: (Monad m, Data a, Typeable a0, Typeable a1) => (a0 -> a1 -> a) -> (a1 -> m a1) -> (a -> m a) decomp22 :: (Monad m, Data a, Typeable a0, Typeable a1) => (a0 -> a1 -> a) -> (a1 -> m a1) -> (a -> m a)
decomp22 con f1 = decomp2 con return f1 decomp22 con f1 = decomp2 con return f1

6
common/FlowGraphTest.hs
View File

@ -112,7 +112,7 @@ testGraph testName nodes roots edges proc = testGraph' testName nodes roots edge
testGraph' :: String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.Structured A.Process -> Test testGraph' :: String -> [(Int, Meta)] -> [Int] -> [(Int, Int, EdgeLabel)] -> A.Structured A.Process -> Test
testGraph' testName nodes roots edges code testGraph' testName nodes roots edges code
= TestCase $ = TestCase $
case evalState (buildFlowGraph testOps code) Map.empty of case evalState (buildFlowGraphP testOps code) Map.empty of
Left err -> assertFailure (testName ++ " graph building failed: " ++ err) 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 A.Process, [Node]))
where where
@ -624,8 +624,8 @@ genProcess' = (1, genProcess)
-- | Generates a flow-graph from the given AST. -- | Generates a flow-graph from the given AST.
-- TODO put this in proper error monad -- TODO put this in proper error monad
genGraph :: Data a => A.Structured a -> FlowGraph' Identity () a genGraph :: A.Structured A.Process -> FlowGraph' Identity () A.Process
genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " ++ e ++ ", from: " ++ pshow s) fst $ runIdentity $ buildFlowGraph funcs s genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " ++ e ++ ", from: " ++ pshow s) fst $ runIdentity $ buildFlowGraphP funcs s
where where
funcs :: GraphLabelFuncs Identity () funcs :: GraphLabelFuncs Identity ()
funcs = mkLabelFuncsConst (return ()) funcs = mkLabelFuncsConst (return ())