diff --git a/Main.hs b/Main.hs index 0ab1e20..5b02e51 100644 --- a/Main.hs +++ b/Main.hs @@ -261,7 +261,7 @@ compile mode fn outHandle do procs <- findAllProcesses let fs :: Data t => t -> PassM String fs = ((liftM $ (take 20) . (filter ((/=) '\"'))) . pshowCode) - let labelFuncs = GLF fs fs fs fs fs fs fs + let labelFuncs = mkLabelFuncsGeneric fs graphs <- mapM ((liftM $ either (const Nothing) Just) . (buildFlowGraph labelFuncs) ) (map (A.OnlyP emptyMeta) (snd $ unzip $ procs)) diff --git a/checks/UsageCheckUtils.hs b/checks/UsageCheckUtils.hs index 298a43a..efa314b 100644 --- a/checks/UsageCheckUtils.hs +++ b/checks/UsageCheckUtils.hs @@ -191,6 +191,7 @@ labelFunctions = GLF ,labelDummy = const (return (Nothing, emptyVars)) ,labelProcess = pair (const Nothing) getVarProc ,labelStartNode = pair (const Nothing) (uncurry getVarFormals) + ,labelReplicator = const (return (Nothing, emptyVars)) --don't forget about the variables used as initialisers in declarations (hence getVarSpec) ,labelScopeIn = pair (getDecl ScopeIn) getVarSpec ,labelScopeOut = pair (getDecl ScopeOut) (const emptyVars) diff --git a/common/FlowGraph.hs b/common/FlowGraph.hs index 7a60173..a7464f9 100644 --- a/common/FlowGraph.hs +++ b/common/FlowGraph.hs @@ -41,7 +41,7 @@ with this program. If not, see . -- * 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, GraphLabelFuncs(..), buildFlowGraph, joinLabelFuncs, makeFlowGraphInstr) where +module FlowGraph (AlterAST(..), EdgeLabel(..), FNode(..), FlowGraph, GraphLabelFuncs(..), buildFlowGraph, joinLabelFuncs, makeFlowGraphInstr, mkLabelFuncsConst, mkLabelFuncsGeneric) where import Control.Monad.Error import Control.Monad.State @@ -80,6 +80,7 @@ data AlterAST m = |AlterArguments (ASTModifier m [A.Formal]) |AlterExpression (ASTModifier m A.Expression) |AlterExpressionList (ASTModifier m A.ExpressionList) + |AlterReplicator (ASTModifier m A.Replicator) |AlterSpec (ASTModifier m A.Specification) |AlterNothing @@ -121,6 +122,7 @@ data Monad m => GraphLabelFuncs m label = GLF { ,labelProcess :: A.Process -> m label ,labelExpression :: A.Expression -> m label ,labelExpressionList :: A.ExpressionList -> m label + ,labelReplicator :: A.Replicator -> m label ,labelScopeIn :: A.Specification -> m label ,labelScopeOut :: A.Specification -> m label } @@ -138,6 +140,7 @@ joinLabelFuncs fx fy = GLF labelProcess = joinItem labelProcess, labelExpression = joinItem labelExpression, labelExpressionList = joinItem labelExpressionList, + labelReplicator = joinItem labelReplicator, labelScopeIn = joinItem labelScopeIn, labelScopeOut = joinItem labelScopeOut } @@ -150,6 +153,12 @@ joinLabelFuncs fx fy = GLF x1 <- f1 x return (x0,x1) +mkLabelFuncsConst :: Monad m => m label -> GraphLabelFuncs m label +mkLabelFuncsConst v = GLF (const v) (const v) (const v) (const v) (const v) (const v) (const v) (const v) + +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 diff --git a/common/FlowGraphTest.hs b/common/FlowGraphTest.hs index 172f721..a4accae 100644 --- a/common/FlowGraphTest.hs +++ b/common/FlowGraphTest.hs @@ -122,7 +122,7 @@ testGraph' testName nodes roots edges code deNode (Node (x,y,_)) = (x,y) testOps :: GraphLabelFuncs (State (Map.Map Meta Int)) Int - testOps = GLF nextId nextId nextId nextId nextId (nextId' 100) (nextId' 100) + testOps = GLF nextId nextId nextId nextId nextId nextId (nextId' 100) (nextId' 100) checkGraphEquality :: (Graph g, Show b, Ord b, Monad m) => ([(Int, Meta)], [Int], [(Int, Int, b)]) -> (g (FNode m Int) b, [Int]) -> Assertion checkGraphEquality (nodes, roots, edges) (g, actRoots) @@ -549,9 +549,7 @@ genProcess n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n genGraph :: A.Structured -> FlowGraph Identity () genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " ++ e ++ ", from: " ++ pshow s) fst $ runIdentity $ buildFlowGraph funcs s where - empty :: a -> Identity () - empty = const (return ()) - funcs = GLF empty empty empty empty empty empty empty + funcs = mkLabelFuncsConst (return ()) -- | Given a flow-graph, it returns a list of all the identity alteration functions, -- for each node. Applying any, many or all of these functions to the source AST