Rearranged FlowGraph and fixed the tests
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
parent
acd57d74de
commit
fa1e9a6a08
|
|
@ -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
|
||||
-- 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.
|
||||
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.Reader
|
||||
import Control.Monad.State
|
||||
import Data.Generics
|
||||
import Data.Graph.Inductive
|
||||
import Data.Graph.Inductive hiding (run)
|
||||
|
||||
import qualified AST as A
|
||||
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)
|
||||
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
|
||||
-- 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 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 func = func funcs
|
||||
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 x = do f <- asks func
|
||||
lift . lift .lift $ f x
|
||||
|
||||
addNode :: (Meta, label, AlterAST mAlter structType) -> GraphMaker mLabel mAlter label structType Node
|
||||
addNode x = do (n,pi,(nodes, edges), rs) <- get
|
||||
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
|
||||
put (n+1, pi,((n, Node x):nodes, edges), rs)
|
||||
return n
|
||||
|
||||
denoteRootNode :: Node -> GraphMaker mLabel mAlter label structType ()
|
||||
denoteRootNode root = do (n, pi, nes, roots) <- get
|
||||
denoteRootNode :: (Monad mLabel, Monad mAlter) => Node -> GraphMaker mLabel mAlter label structType ()
|
||||
denoteRootNode root = do (n, pi, nes, roots) <- get
|
||||
put (n, pi, nes, root : roots)
|
||||
|
||||
addEdge :: EdgeLabel -> Node -> Node -> GraphMaker mLabel mAlter label structType ()
|
||||
addEdge label start end = do (n, pi, (nodes, edges), rs) <- get
|
||||
addEdge :: (Monad mLabel, Monad mAlter) => EdgeLabel -> Node -> Node -> GraphMaker mLabel mAlter label structType ()
|
||||
addEdge label start end = do (n, pi, (nodes, edges), rs) <- get
|
||||
-- Edges should only be added after the nodes, so
|
||||
-- for safety here we can check that the nodes exist:
|
||||
if (notElem start $ map fst nodes) || (notElem end $ map fst nodes)
|
||||
then throwError "Could not add edge between non-existent nodes"
|
||||
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
|
||||
-- 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' m f t r = do val <- (lift . lift) (run f t)
|
||||
-- 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
|
||||
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 <- run f t
|
||||
addNode (m, val, r)
|
||||
|
||||
addNodeExpression :: 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 :: (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)
|
||||
|
||||
addNodeExpressionList :: 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 :: (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)
|
||||
|
||||
addDummyNode :: Meta -> GraphMaker mLabel mAlter label structType Node
|
||||
addDummyNode m = addNode' m labelDummy m AlterNothing
|
||||
addDummyNode :: (Monad mLabel, Monad mAlter) => Meta -> GraphMaker mLabel mAlter label structType Node
|
||||
addDummyNode m = addNode' m labelDummy m AlterNothing
|
||||
|
||||
getNextParEdgeId :: GraphMaker mLabel mAlter label structType Int
|
||||
getNextParEdgeId = do (a, pi, b, c) <- get
|
||||
getNextParEdgeId :: (Monad mLabel, Monad mAlter) => GraphMaker mLabel mAlter label structType Int
|
||||
getNextParEdgeId = do (a, pi, b, c) <- get
|
||||
put (a, pi + 1, b, c)
|
||||
return pi
|
||||
|
||||
addParEdges :: Int -> (Node,Node) -> [(Node,Node)] -> GraphMaker mLabel mAlter label structType ()
|
||||
addParEdges usePI (s,e) pairs
|
||||
addParEdges :: (Monad mLabel, Monad mAlter) => Int -> (Node,Node) -> [(Node,Node)] -> GraphMaker mLabel mAlter label structType ()
|
||||
addParEdges usePI (s,e) pairs
|
||||
= do (n,pi,(nodes,edges),rs) <- get
|
||||
put (n,pi,(nodes,edges ++ (concatMap (parEdge usePI) pairs)),rs)
|
||||
where
|
||||
parEdge :: Int -> (Node, Node) -> [LEdge EdgeLabel]
|
||||
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
|
||||
-- which has the synonym Route m innerType outerType
|
||||
-- The build-up functions are all of type (innerType -> m innerType) -> outerType -> m outerType
|
||||
-- which has the synonym Route m innerType outerType
|
||||
|
||||
getN :: Int -> [a] -> ([a],a,[a])
|
||||
getN n xs = let (f,(m:e)) = splitAt n xs in (f,m,e)
|
||||
getN :: Int -> [a] -> ([a],a,[a])
|
||||
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 n f xs
|
||||
routeList :: Monad m => Int -> (a -> m a) -> ([a] -> m [a])
|
||||
routeList n f xs
|
||||
= do let (pre,x,suf) = getN n xs
|
||||
x' <- f x
|
||||
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 outerRoute func xs = mapM funcAndRoute (zip [0..] xs)
|
||||
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)
|
||||
where
|
||||
funcAndRoute :: (Int, inner) -> GraphMaker mLabel mAlter label structType (Node,Node)
|
||||
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 outerRoute func xs = mapM funcAndRoute (zip [0..] xs) >>* foldl foldEither (Left False)
|
||||
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)
|
||||
where
|
||||
foldEither :: Either Bool [(Node,Node)] -> Either Bool (Node,Node) -> Either Bool [(Node,Node)]
|
||||
foldEither (Left _) (Right n) = Right [n]
|
||||
|
|
@ -276,25 +261,32 @@ buildFlowGraph funcs s
|
|||
funcAndRoute (ind,x) = func x (outerRoute @-> routeList ind)
|
||||
|
||||
|
||||
nonEmpty :: Either Bool [(Node,Node)] -> Bool
|
||||
nonEmpty (Left hadNodes) = hadNodes
|
||||
nonEmpty (Right nodes) = not (null nodes)
|
||||
nonEmpty :: Either Bool [(Node,Node)] -> Bool
|
||||
nonEmpty (Left hadNodes) = hadNodes
|
||||
nonEmpty (Right nodes) = not (null nodes)
|
||||
|
||||
joinPairs :: Meta -> [(Node, Node)] -> GraphMaker mLabel mAlter label structType (Node, Node)
|
||||
joinPairs m [] = addDummyNode m >>* mkPair
|
||||
joinPairs m nodes = do sequence_ $ mapPairs (\(_,s) (e,_) -> addEdge ESeq s e) nodes
|
||||
joinPairs :: (Monad mLabel, Monad mAlter) => Meta -> [(Node, Node)] -> GraphMaker mLabel mAlter label structType (Node, Node)
|
||||
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 = buildStructured (\_ r p -> buildProcess p r)
|
||||
buildStructuredC = buildStructured buildOnlyChoice
|
||||
buildStructuredO = buildStructured buildOnlyOption
|
||||
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. Data a => (OuterType -> ASTModifier mAlter a structType -> a -> GraphMaker mLabel mAlter label structType (Node, Node)) ->
|
||||
-- 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
|
||||
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
|
||||
|
|
@ -322,7 +314,7 @@ buildFlowGraph funcs s
|
|||
decompSeveral :: ASTModifier mAlter [A.Structured a] structType
|
||||
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)
|
||||
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
|
||||
addEdge ESeq e 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
|
||||
case outer of
|
||||
OSeq -> do n <- addNode' (findMeta rep) labelReplicator rep alter
|
||||
|
|
@ -372,10 +364,10 @@ buildFlowGraph funcs s
|
|||
return $ Right (s,e)
|
||||
_ -> throwError $ "Cannot have replicators inside context: " ++ show outer
|
||||
|
||||
buildStructured f outer (A.Only _ o) route = f outer (route22 route A.Only) o >>* Right
|
||||
buildStructured _ _ s _ = return $ Left False
|
||||
buildStructured f outer (A.Only _ o) route = f outer (route22 route A.Only) o >>* Right
|
||||
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
|
||||
(nbodys, nbodye) <- buildProcess p $ route33 route A.Choice
|
||||
addEdge ESeq nexp nbodys
|
||||
|
|
@ -385,7 +377,7 @@ buildFlowGraph funcs s
|
|||
addEdge ESeq nbodye cEnd
|
||||
_ -> throwError "Choice found outside IF statement"
|
||||
return (nexp,nbodye)
|
||||
buildOnlyOption outer route opt
|
||||
buildOnlyOption outer route opt
|
||||
= do (s,e) <-
|
||||
case opt of
|
||||
(A.Option m es p) -> do
|
||||
|
|
@ -402,9 +394,10 @@ buildFlowGraph funcs s
|
|||
_ -> throwError "Option found outside CASE statement"
|
||||
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 ()
|
||||
addNewSubProcFunc m args body argsRoute
|
||||
addNewSubProcFunc m args body argsRoute
|
||||
= do root <- addNode' m labelStartNode (m, args) (AlterArguments argsRoute)
|
||||
denoteRootNode root
|
||||
bodyNode <- case body of
|
||||
|
|
@ -418,15 +411,15 @@ buildFlowGraph funcs s
|
|||
where
|
||||
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 (A.Seq m s) route
|
||||
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
|
||||
buildProcess (A.Par m _ s) route
|
||||
buildProcess (A.Par m _ s) route
|
||||
= do nStart <- addDummyNode m
|
||||
nEnd <- addDummyNode m
|
||||
pId <- getNextParEdgeId
|
||||
|
|
@ -438,23 +431,53 @@ buildFlowGraph funcs s
|
|||
do addEdge (EStartPar pId) nStart start
|
||||
addEdge (EEndPar pId) end 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)
|
||||
(start, end) <- buildProcess p (route33 route A.While)
|
||||
addEdge ESeq n start
|
||||
addEdge ESeq end 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)
|
||||
nEnd <- addDummyNode m
|
||||
buildStructuredO (OCase (nStart,nEnd)) s (route33 route A.Case)
|
||||
return (nStart, nEnd)
|
||||
buildProcess (A.If m s) route
|
||||
buildProcess (A.If m s) route
|
||||
= do nStart <- addDummyNode m
|
||||
nEnd <- addDummyNode m
|
||||
buildStructuredC (OIf nStart nEnd) s (route22 route A.If)
|
||||
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 con f1 = decomp2 con return f1
|
||||
|
|
|
|||
|
|
@ -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' testName nodes roots edges code
|
||||
= 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)
|
||||
Right gr -> checkGraphEquality (nodes, roots, edges) (gr :: (FlowGraph' Identity Int A.Process, [Node]))
|
||||
where
|
||||
|
|
@ -624,8 +624,8 @@ genProcess' = (1, genProcess)
|
|||
|
||||
-- | Generates a flow-graph from the given AST.
|
||||
-- TODO put this in proper error monad
|
||||
genGraph :: Data a => A.Structured a -> FlowGraph' Identity () a
|
||||
genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " ++ e ++ ", from: " ++ pshow s) fst $ runIdentity $ buildFlowGraph funcs s
|
||||
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 $ buildFlowGraphP funcs s
|
||||
where
|
||||
funcs :: GraphLabelFuncs Identity ()
|
||||
funcs = mkLabelFuncsConst (return ())
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user