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

99
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,37 +179,21 @@ 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:
@ -218,25 +203,25 @@ buildFlowGraph funcs s
-- 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)
@ -256,14 +241,14 @@ buildFlowGraph funcs s
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)]
@ -280,19 +265,26 @@ buildFlowGraph funcs s
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 :: (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) 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 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 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
@ -402,7 +394,8 @@ 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)
@ -418,7 +411,7 @@ 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
@ -456,6 +449,36 @@ buildFlowGraph funcs s
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 ())