Added a new labelling function to FlowGraph for labelling the arguments of functions/processes

Main.hs

@@ -252,7 +252,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
+                 let labelFuncs = GLF fs fs fs fs fs fs fs
                  graphs <- mapM
                       ((liftM $ either (const Nothing) Just) . (buildFlowGraph labelFuncs) )
                       (map (A.OnlyP emptyMeta) (snd $ unzip $ procs))

checks/UsageCheckUtils.hs

@@ -26,6 +26,7 @@ import qualified Data.Set as Set
 import qualified AST as A
 import Errors
 import FlowGraph
+import Metadata
 import OrdAST()
 import ShowCode
 
@@ -174,6 +175,13 @@ getVarSpec = const emptyVars -- TODO
 getDecl :: (String -> Decl) -> A.Specification -> Maybe Decl
 getDecl _ _ = Nothing -- TODO
 
+getVarFormals :: Meta -> [A.Formal] -> Vars
+getVarFormals m = mapUnionVars (getVarFormal m)
+  where
+    -- We treat formal parameters as being written-to, so that they
+    -- appear initialised at the beginning of the function
+    getVarFormal :: Meta -> A.Formal -> Vars
+    getVarFormal m (A.Formal _ _ n) = processVarW $ A.Variable m n
 
 labelFunctions :: forall m. Die m => GraphLabelFuncs m (Maybe Decl, Vars)
 labelFunctions = GLF
@@ -182,6 +190,7 @@ labelFunctions = GLF
   ,labelExpressionList = pair (const Nothing) getVarExpList
   ,labelDummy = const (return (Nothing, emptyVars))
   ,labelProcess = pair (const Nothing) getVarProc
+  ,labelStartNode = pair (const Nothing) (uncurry getVarFormals)
   --don't forget about the variables used as initialisers in declarations (hence getVarSpec)
   ,labelScopeIn = pair (getDecl ScopeIn) getVarSpec
   ,labelScopeOut = pair (getDecl ScopeOut) (const emptyVars)

common/FlowGraph.hs

@@ -77,6 +77,7 @@ type ASTModifier m inner = (inner -> m inner) -> (A.Structured -> m A.Structured
 -- | A choice of AST altering functions built on ASTModifier.
 data AlterAST m = 
   AlterProcess (ASTModifier m A.Process)
+ |AlterArguments (ASTModifier m [A.Formal])
  |AlterExpression (ASTModifier m A.Expression)
  |AlterExpressionList (ASTModifier m A.ExpressionList)
  |AlterSpec (ASTModifier m A.Specification)
@@ -116,6 +117,7 @@ type GraphMaker mLabel mAlter a b = ErrorT String (StateT (GraphMakerState mAlte
 -- can simply ignore it if they want.
 data Monad m => GraphLabelFuncs m label = GLF {
      labelDummy :: Meta -> m label
+    ,labelStartNode :: (Meta, [A.Formal]) -> m label
     ,labelProcess :: A.Process -> m label
     ,labelExpression :: A.Expression -> m label
     ,labelExpressionList :: A.ExpressionList -> m label
@@ -132,6 +134,7 @@ joinLabelFuncs :: forall a b m. Monad m => GraphLabelFuncs m a -> GraphLabelFunc
 joinLabelFuncs fx fy = GLF
  {
   labelDummy = joinItem labelDummy,
+  labelStartNode = joinItem labelStartNode,
   labelProcess = joinItem labelProcess,
   labelExpression = joinItem labelExpression,
   labelExpressionList = joinItem labelExpressionList,
@@ -295,12 +298,12 @@ buildFlowGraph funcs s
            -- If it's a process or function spec we must process it too.  No need to
            -- connect it up to the outer part though
            case spec of
-             (A.Specification _ _ (A.Proc _ _ _ p)) ->
-               buildProcess p (route44 (route33 (route23 route A.Spec) A.Specification) A.Proc)
-                 >>= denoteRootNode . fst
-             (A.Specification _ _ (A.Function _ _ _ _ s)) ->
-               buildStructured None s (route55 (route33 (route23 route A.Spec) A.Specification) A.Function)
-                 >>= denoteRootNode . fst
+             (A.Specification _ _ (A.Proc m _ args p)) ->
+               let procRoute = (route33 (route23 route A.Spec) A.Specification) in
+               addNewSubProcFunc m args (Left (p, route44 procRoute A.Proc)) (route34 procRoute A.Proc)
+             (A.Specification _ _ (A.Function m _ _ args s)) ->
+               let funcRoute = (route33 (route23 route A.Spec) A.Specification) in
+               addNewSubProcFunc m args (Right (s, route55 funcRoute A.Function)) (route45 funcRoute A.Function)
              _ -> return ()
            addEdge ESeq n s
            addEdge ESeq e n'
@@ -308,6 +311,16 @@ buildFlowGraph funcs s
     -- TODO replicator
     buildStructured _ s _ = do n <- addDummyNode (findMeta s)
                                return (n,n)
+
+    addNewSubProcFunc :: Meta -> [A.Formal] -> Either (A.Process, ASTModifier mAlter A.Process) (A.Structured, ASTModifier mAlter A.Structured) ->
+      ASTModifier mAlter [A.Formal] -> GraphMaker mLabel mAlter label ()
+    addNewSubProcFunc m args body argsRoute
+      = do root <- addNode' m labelStartNode (m, args) (AlterArguments argsRoute)
+           denoteRootNode root
+           bodyNode <- case body of
+             Left (p,route) -> buildProcess p route >>* fst
+             Right (s,route) -> buildStructured None s route >>* fst
+           addEdge ESeq root bodyNode
     
     buildProcess :: A.Process -> ASTModifier mAlter A.Process -> GraphMaker mLabel mAlter label (Node, Node)
     buildProcess (A.Seq _ s) route = buildStructured Seq s (route22 route A.Seq)
@@ -339,10 +352,18 @@ decomp23 con f1 = decomp3 con return f1 return
 decomp33 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => (a0 -> a1 -> a2 -> a) -> (a2 -> m a2) -> (a -> m a)
 decomp33 con f2 = decomp3 con return return f2
 
+decomp34 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
+  (a0 -> a1 -> a2 -> a3 -> a) -> (a2 -> m a2) -> (a -> m a)
+decomp34 con f2 = decomp4 con return return f2 return
+
 decomp44 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
   (a0 -> a1 -> a2 -> a3 -> a) -> (a3 -> m a3) -> (a -> m a)
 decomp44 con f3 = decomp4 con return return return f3
 
+decomp45 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
+  (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a3 -> m a3) -> (a -> m a)
+decomp45 con f3 = decomp5 con return return return f3 return
+
 decomp55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
   (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a4 -> m a4) -> (a -> m a)
 decomp55 con f4 = decomp5 con return return return return f4
@@ -356,10 +377,18 @@ route23 route con = route @-> (decomp23 con)
 route33 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => ASTModifier m a -> (a0 -> a1 -> a2 -> a) -> ASTModifier m a2
 route33 route con = route @-> (decomp33 con)
 
+route34 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
+  ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a) -> ASTModifier m a2
+route34 route con = route @-> (decomp34 con)
+
 route44 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
   ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a) -> ASTModifier m a3
 route44 route con = route @-> (decomp44 con)
 
+route45 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
+  ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> ASTModifier m a3
+route45 route con = route @-> (decomp45 con)
+
 route55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
   ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> ASTModifier m a4
 route55 route con = route @-> (decomp55 con)

common/FlowGraphTest.hs

@@ -122,7 +122,7 @@ testGraph' testName nodes edges code
     deNode (Node (x,y,_)) = (x,y)
     
     testOps :: GraphLabelFuncs (State (Map.Map Meta Int)) Int
-    testOps = GLF nextId nextId nextId nextId (nextId' 100) (nextId' 100)
+    testOps = GLF nextId nextId nextId nextId nextId (nextId' 100) (nextId' 100)
     
     checkGraphEquality :: (Graph g, Show b, Ord b, Monad m) => ([(Int, Meta)], [(Int, Int, b)]) -> g (FNode m Int) b -> Assertion
     checkGraphEquality (nodes, edges) g
@@ -541,7 +541,7 @@ genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " +
   where
     empty :: a -> Identity ()
     empty = const (return ())
-    funcs = GLF empty empty empty empty empty empty 
+    funcs = GLF empty empty empty empty empty empty empty
 
 -- | 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