Augmented the flow graph building to store in each node a list of the names defined at that point
This commit is contained in:
Neil Brown
parent
3da315497a
commit
b08ac42547
|
|
@ -96,7 +96,7 @@ buildStructuredAST (A.Several _ ss) route
|
|||
return ()
|
||||
buildStructuredAST (A.Spec _ spec str) route
|
||||
= do buildProcessOrFunctionSpec spec (route23 route A.Spec)
|
||||
buildStructuredAST str (route33 route A.Spec)
|
||||
withDeclSpec spec $ buildStructuredAST str (route33 route A.Spec)
|
||||
buildStructuredAST s _ = throwError $ "Unexpected element at top-level: " ++ show s
|
||||
|
||||
buildStructuredEL :: (Monad mLabel, Monad mAlter) => A.Structured A.ExpressionList -> ASTModifier mAlter (A.Structured A.ExpressionList) structType ->
|
||||
|
|
@ -110,7 +110,7 @@ buildStructuredEL (A.ProcThen _ p str) route
|
|||
buildStructuredEL (A.Spec m spec str) route
|
||||
= do (n,n') <- addSpecNodes spec route
|
||||
buildProcessOrFunctionSpec spec (route23 route A.Spec)
|
||||
(s,e) <- buildStructuredEL str (route33 route A.Spec)
|
||||
(s,e) <- withDeclSpec spec $ buildStructuredEL str (route33 route A.Spec)
|
||||
n --> s
|
||||
e --> n'
|
||||
return (n, n')
|
||||
|
|
@ -124,7 +124,7 @@ buildStructuredAltNoSpecs :: (Monad mLabel, Monad mAlter) => (Node,Node) -> A.St
|
|||
-- of constraints on i (TODO record the replicators in ALTs somehow)
|
||||
-- only one of the replicated guards will be chosen, so we can effectively
|
||||
-- ignore the replication (in terms of the flow graph at least)
|
||||
buildStructuredAltNoSpecs se (A.Spec _ _ str) route = buildStructuredAltNoSpecs se str (route33 route A.Spec)
|
||||
buildStructuredAltNoSpecs se (A.Spec _ spec str) route = withDeclSpec spec $ buildStructuredAltNoSpecs se str (route33 route A.Spec)
|
||||
buildStructuredAltNoSpecs se (A.Several m ss) route
|
||||
= mapMR (route22 route A.Several) (buildStructuredAltNoSpecs se) ss >> return ()
|
||||
buildStructuredAltNoSpecs se (A.ProcThen _ _ str) route
|
||||
|
|
@ -152,7 +152,7 @@ buildJustSpecs (A.Only {}) _ = return Nothing
|
|||
buildJustSpecs (A.Several _ ss) route = mapMR (route22 route A.Several) buildJustSpecs ss >>= foldSpecs
|
||||
buildJustSpecs (A.Spec _ spec str) route
|
||||
= do (scopeIn, scopeOut) <- addSpecNodes spec route
|
||||
inner <- buildJustSpecs str (route33 route A.Spec)
|
||||
inner <- withDeclSpec spec $ buildJustSpecs str (route33 route A.Spec)
|
||||
case inner of
|
||||
Nothing -> return $ Just ((scopeIn, scopeIn), (scopeOut, scopeOut))
|
||||
Just ((innerInStart, innerInEnd), (innerOutStart, innerOutEnd)) ->
|
||||
|
|
@ -173,17 +173,17 @@ buildStructuredSeq :: (Monad mLabel, Monad mAlter) => A.Structured A.Process ->
|
|||
buildStructuredSeq (A.Several m ss) route
|
||||
= do nodes <- mapMR (route22 route A.Several) buildStructuredSeq ss
|
||||
joinPairs m route nodes
|
||||
buildStructuredSeq (A.Spec m (A.Specification mspec nm (A.Rep mrep rep)) str) route
|
||||
buildStructuredSeq (A.Spec m spec@(A.Specification mspec nm (A.Rep mrep rep)) str) route
|
||||
= let alter = AlterReplicator $ route22 (route33 (route23 route A.Spec) A.Specification) A.Rep in
|
||||
do n <- addNode' (findMeta rep) labelReplicator (nm, rep) alter
|
||||
(s,e) <- buildStructuredSeq str (route33 route A.Spec)
|
||||
(s,e) <- withDeclSpec spec $ buildStructuredSeq str (route33 route A.Spec)
|
||||
n --> s
|
||||
e --> n
|
||||
return (n, n)
|
||||
buildStructuredSeq (A.Spec m spec str) route
|
||||
= do (n,n') <- addSpecNodes spec route
|
||||
buildProcessOrFunctionSpec spec (route23 route A.Spec)
|
||||
(s,e) <- buildStructuredSeq str (route33 route A.Spec)
|
||||
(s,e) <- withDeclSpec spec $ buildStructuredSeq str (route33 route A.Spec)
|
||||
n --> s
|
||||
e --> n'
|
||||
return (n, n')
|
||||
|
|
@ -201,12 +201,12 @@ buildStructuredPar pId (nStart, nEnd) (A.Several m ss) route
|
|||
= do nodes <- mapMRE (route22 route A.Several) (buildStructuredPar pId (nStart, nEnd)) ss
|
||||
addParEdges pId (nStart, nEnd) $ either (const []) id nodes
|
||||
return $ Left $ nonEmpty nodes
|
||||
buildStructuredPar pId (nStart, nEnd) (A.Spec mstr (A.Specification mspec nm (A.Rep m rep)) str) route
|
||||
buildStructuredPar pId (nStart, nEnd) (A.Spec mstr spec@(A.Specification mspec nm (A.Rep m rep)) str) route
|
||||
= let alter = AlterReplicator $ route22 (route33 (route23 route A.Spec) A.Specification) A.Rep in
|
||||
do s <- addNode' (findMeta rep) labelReplicator (nm, rep) alter
|
||||
e <- addDummyNode m route
|
||||
pId' <- getNextParEdgeId
|
||||
nodes <- buildStructuredPar pId' (s,e) str (route33 route A.Spec)
|
||||
nodes <- withDeclSpec spec $ buildStructuredPar pId' (s,e) str (route33 route A.Spec)
|
||||
case nodes of
|
||||
Left False -> s --> e
|
||||
Left True -> return ()
|
||||
|
|
@ -217,7 +217,7 @@ buildStructuredPar pId (nStart, nEnd) (A.Spec m spec str) route
|
|||
= do (n,n') <- addSpecNodes spec route
|
||||
pId' <- getNextParEdgeId
|
||||
buildProcessOrFunctionSpec spec (route23 route A.Spec)
|
||||
nodes <- buildStructuredPar pId' (n, n') str (route33 route A.Spec)
|
||||
nodes <- withDeclSpec spec $ buildStructuredPar pId' (n, n') str (route33 route A.Spec)
|
||||
case nodes of
|
||||
Left False -> n --> n'
|
||||
Left True -> return ()
|
||||
|
|
@ -251,7 +251,7 @@ buildStructuredCase (nStart, nEnd) (A.Spec _ spec str) route
|
|||
= do (n, n') <- addSpecNodes spec route
|
||||
nStart --> n
|
||||
n' --> nEnd
|
||||
buildStructuredCase (n, n') str (route33 route A.Spec)
|
||||
withDeclSpec spec $ buildStructuredCase (n, n') str (route33 route A.Spec)
|
||||
|
||||
buildStructuredIf :: forall mLabel mAlter label structType. (Monad mLabel, Monad mAlter) => (Node, Node) -> A.Structured A.Choice -> ASTModifier mAlter (A.Structured A.Choice) structType ->
|
||||
GraphMaker mLabel mAlter label structType Node
|
||||
|
|
@ -266,10 +266,10 @@ buildStructuredIf (prev, end) (A.ProcThen _ p str) route
|
|||
buildStructuredIf (pe, end) str (route33 route A.ProcThen)
|
||||
buildStructuredIf (prev, end) (A.Only _ c) route
|
||||
= buildOnlyChoice (prev, end) (route22 route A.Only) c
|
||||
buildStructuredIf (prev, end) (A.Spec _ (A.Specification _ nm (A.Rep _ rep)) str) route
|
||||
buildStructuredIf (prev, end) (A.Spec _ spec@(A.Specification _ nm (A.Rep _ rep)) str) route
|
||||
= let alter = AlterReplicator $ route22 (route33 (route23 route A.Spec) A.Specification) A.Rep in
|
||||
do repNode <- addNode' (findMeta rep) labelReplicator (nm, rep) alter
|
||||
lastNode <- buildStructuredIf (repNode, end) str (route33 route A.Spec)
|
||||
lastNode <- withDeclSpec spec $ buildStructuredIf (repNode, end) str (route33 route A.Spec)
|
||||
prev --> repNode
|
||||
lastNode --> repNode
|
||||
return repNode
|
||||
|
|
@ -282,7 +282,7 @@ buildStructuredIf (prev, end) (A.Spec _ spec str) route
|
|||
nOutBlock <- addNode' (findMeta spec) labelScopeOut spec (AlterSpec $ route23 route A.Spec)
|
||||
nOutNext <- addNode' (findMeta spec) labelScopeOut spec (AlterSpec $ route23 route A.Spec)
|
||||
|
||||
last <- buildStructuredIf (nIn, nOutBlock) str (route33 route A.Spec)
|
||||
last <- withDeclSpec spec $ buildStructuredIf (nIn, nOutBlock) str (route33 route A.Spec)
|
||||
|
||||
prev --> nIn
|
||||
when (last /= prev) $ -- Only add the edge if there was a block it's connected to!
|
||||
|
|
@ -405,10 +405,10 @@ buildFlowGraph :: forall mLabel mAlter label. (Monad mLabel, Monad mAlter) =>
|
|||
A.AST ->
|
||||
mLabel (Either String (FlowGraph' mAlter label (), [Node], [Node]))
|
||||
buildFlowGraph funcs s
|
||||
= do res <- flip runStateT (GraphMakerState 0 0 ([],[]) [] []) $ flip runReaderT funcs $ runErrorT $ buildStructuredAST s routeIdentity
|
||||
= do res <- flip runStateT (GraphMakerState 0 0 ([],[]) [] [] []) $ flip runReaderT funcs $ runErrorT $ buildStructuredAST s routeIdentity
|
||||
return $ case res of
|
||||
(Left err,_) -> Left err
|
||||
(Right _,GraphMakerState _ _ (nodes, edges) roots terminators)
|
||||
(Right _,GraphMakerState _ _ (nodes, edges) roots terminators _)
|
||||
-> Right (mkGraph nodes edges, roots, terminators)
|
||||
|
||||
buildFlowGraphP :: forall mLabel mAlter label. (Monad mLabel, Monad mAlter) =>
|
||||
|
|
@ -416,10 +416,10 @@ buildFlowGraphP :: forall mLabel mAlter label. (Monad mLabel, Monad mAlter) =>
|
|||
A.Structured A.Process ->
|
||||
mLabel (Either String (FlowGraph' mAlter label A.Process, [Node], [Node]))
|
||||
buildFlowGraphP funcs s
|
||||
= do res <- flip runStateT (GraphMakerState 0 0 ([],[]) [] []) $ flip runReaderT funcs $ runErrorT $ buildStructuredSeq s routeIdentity
|
||||
= do res <- flip runStateT (GraphMakerState 0 0 ([],[]) [] [] []) $ flip runReaderT funcs $ runErrorT $ buildStructuredSeq s routeIdentity
|
||||
return $ case res of
|
||||
(Left err,_) -> Left err
|
||||
(Right (root,_),GraphMakerState _ _ (nodes, edges) roots terminators)
|
||||
(Right (root,_),GraphMakerState _ _ (nodes, edges) roots terminators _)
|
||||
-> Right (mkGraph nodes edges, root : roots, terminators)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -61,10 +61,10 @@ data AlterAST m structType =
|
|||
deriving (Show)
|
||||
|
||||
data Monad mAlter => FNode' structType mAlter label
|
||||
= Node (Meta, label, AlterAST mAlter structType)
|
||||
= Node (Meta, label, [String], AlterAST mAlter structType)
|
||||
|
||||
instance Monad m => Functor (FNode' s m) where
|
||||
fmap f (Node (m, l, a)) = Node (m, f l, a)
|
||||
fmap f (Node (m, l, ns, a)) = Node (m, f l, ns, a)
|
||||
|
||||
-- | The label for a node. A Meta tag, a custom label, and a function
|
||||
-- for altering the part of the AST that this node came from
|
||||
|
|
@ -72,7 +72,7 @@ type FNode mAlter label = FNode' () mAlter label
|
|||
--type FEdge = (Node, EdgeLabel, Node)
|
||||
|
||||
instance (Monad m, Show a) => Show (FNode' b m a) where
|
||||
show (Node (m,x,r)) = (filter ((/=) '\"')) $ show m ++ ":" ++ show x ++ "<" ++ show r
|
||||
show (Node (m,x,_,r)) = (filter ((/=) '\"')) $ show m ++ ":" ++ show x ++ "<" ++ show r
|
||||
|
||||
type FlowGraph' mAlter label structType = Gr (FNode' structType mAlter label) EdgeLabel
|
||||
|
||||
|
|
@ -96,6 +96,7 @@ data GraphMakerState mAlter a b = GraphMakerState
|
|||
, graphNodesEdges :: NodesEdges mAlter a b
|
||||
, rootNodes :: [Node]
|
||||
, termNodes :: [Node]
|
||||
, nameStack :: [String]
|
||||
}
|
||||
|
||||
type GraphMaker mLabel mAlter a b c = ErrorT String (ReaderT (GraphLabelFuncs mLabel a) (StateT (GraphMakerState mAlter a b) mLabel)) c
|
||||
|
|
@ -121,13 +122,16 @@ data Monad m => GraphLabelFuncs m label = GLF {
|
|||
}
|
||||
|
||||
getNodeMeta :: Monad m => FNode' b m a -> Meta
|
||||
getNodeMeta (Node (m,_,_)) = m
|
||||
getNodeMeta (Node (m,_,_,_)) = m
|
||||
|
||||
getNodeData :: Monad m => FNode' b m a -> a
|
||||
getNodeData (Node (_,d,_)) = d
|
||||
getNodeData (Node (_,d,_,_)) = d
|
||||
|
||||
getNodeFunc :: Monad m => FNode' b m a -> AlterAST m b
|
||||
getNodeFunc (Node (_,_,f)) = f
|
||||
getNodeFunc (Node (_,_,_,f)) = f
|
||||
|
||||
getNodeNames :: Monad m => FNode' b m a -> [String]
|
||||
getNodeNames (Node (_,_,ns,_)) = ns
|
||||
|
||||
getNodeRouteId :: Monad m => FNode' b m a -> [Int]
|
||||
getNodeRouteId = get . getNodeFunc
|
||||
|
|
@ -142,7 +146,7 @@ getNodeRouteId = get . getNodeFunc
|
|||
get (AlterNothing r) = r
|
||||
|
||||
makeTestNode :: Monad m => Meta -> a -> FNode m a
|
||||
makeTestNode m d = Node (m,d,undefined)
|
||||
makeTestNode m d = Node (m,d,[],undefined)
|
||||
|
||||
-- | Builds the instructions to send to GraphViz
|
||||
makeFlowGraphInstr :: (Monad m, Show a, Data b) => FlowGraph' m a b -> String
|
||||
|
|
@ -184,10 +188,12 @@ run func x = do f <- asks func
|
|||
lift . lift .lift $ f x
|
||||
|
||||
addNode :: (Monad mLabel, Monad mAlter) => (Meta, label, AlterAST mAlter structType) -> GraphMaker mLabel mAlter label structType Node
|
||||
addNode x = do st <- get
|
||||
addNode (x, y, z)
|
||||
= do st <- get
|
||||
let (nodes, edges) = graphNodesEdges st
|
||||
put $ st { nextNodeId = nextNodeId st + 1
|
||||
, graphNodesEdges = ((nextNodeId st, Node x):nodes, edges)
|
||||
, graphNodesEdges = ((nextNodeId st,
|
||||
Node (x,y,nameStack st, z)):nodes, edges)
|
||||
}
|
||||
return $ nextNodeId st
|
||||
|
||||
|
|
@ -214,7 +220,24 @@ addEdge label start end = do st <- get
|
|||
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)
|
||||
|
||||
|
||||
withDeclName :: (Monad mLabel, Monad mAlter) =>
|
||||
String ->
|
||||
GraphMaker mLabel mAlter label structType a ->
|
||||
GraphMaker mLabel mAlter label structType a
|
||||
withDeclName n m = do st <- get
|
||||
put $ st {nameStack = n : nameStack st}
|
||||
x <- m
|
||||
st' <- get
|
||||
put $ st' {nameStack = tail $ nameStack st}
|
||||
return x
|
||||
|
||||
withDeclSpec :: (Monad mLabel, Monad mAlter) =>
|
||||
A.Specification ->
|
||||
GraphMaker mLabel mAlter label structType a ->
|
||||
GraphMaker mLabel mAlter label structType a
|
||||
withDeclSpec (A.Specification _ n _) = withDeclName (A.nameName n)
|
||||
|
||||
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)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user