Changed the FlowGraph stuff to use the new Route type (that includes identifiers) rather than the bare functions as it used to

common/GenericUtils.hs

@@ -28,7 +28,8 @@ module GenericUtils (
   , containsTypes
   , gmapMFor
   , gmapMForRoute
-  , routeModify, routeGet, routeSet, Route, (@->), routeIdentity, routeId
+  , routeModify, routeGet, routeSet, Route(..), (@->), routeIdentity, routeId, routeList
+  , route22, route23, route33, route34, route44, route45, route55
   , baseTransformRoute, extTransformRoute
   ) where
 
@@ -173,6 +174,10 @@ instance Ord (Route inner outer) where
 routeId :: Route inner outer -> [Int]
 routeId (Route ns _) = ns
 
+routeList :: Int -> Route a [a]
+routeList 0 = Route [0] (\f (x:xs) -> f x >>* (: xs))
+routeList n = Route [1] (\f (x:xs) -> f xs >>* (x:)) @-> routeList (n-1)
+
 routeModify :: Monad m => Route inner outer -> (inner -> m inner) -> (outer -> m
   outer)
 routeModify (Route _ wrap) = wrap
@@ -226,3 +231,53 @@ extTransformRoute generalFunc specificFunc (x, route)
 -- Given a number, makes a route function for that child:
 makeRoute :: (Data s, Data t) => Int -> Route s t
 makeRoute target = Route [target] (\f -> gmapFuncs [mkM' (if n == target then f else return) | n <- [0..]])
+
+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
+
+decomp23 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => (a0 -> a1 -> a2 -> a) -> (a1 -> m a1) -> (a -> m a)
+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
+
+route22 :: (Data a, Typeable a0, Typeable a1) => Route a b -> (a0 -> a1 -> a) -> Route a1 b
+route22 route con = route @-> Route [1] (decomp22 con)
+
+route23 :: (Data a, Typeable a0, Typeable a1, Typeable a2) => Route a b -> (a0 -> a1 -> a2 -> a) -> Route a1 b
+route23 route con = route @-> Route [1] (decomp23 con)
+
+route33 :: (Data a, Typeable a0, Typeable a1, Typeable a2) => Route a b -> (a0 -> a1 -> a2 -> a) -> Route a2 b
+route33 route con = route @-> Route [2] (decomp33 con)
+
+route34 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
+  Route a b -> (a0 -> a1 -> a2 -> a3 -> a) -> Route a2 b
+route34 route con = route @-> Route [2] (decomp34 con)
+
+route44 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
+  Route a b -> (a0 -> a1 -> a2 -> a3 -> a) -> Route a3 b
+route44 route con = route @-> Route [3] (decomp44 con)
+
+route45 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
+  Route a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> Route a3 b
+route45 route con = route @-> Route [3] (decomp45 con)
+
+route55 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
+  Route a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> Route a4 b
+route55 route con = route @-> Route [4] (decomp55 con)

flow/FlowGraph.hs

@@ -51,6 +51,7 @@ import Data.Graph.Inductive hiding (run)
 import Data.Maybe
 
 import qualified AST as A
+import GenericUtils
 import Metadata
 import FlowUtils
 import Utils
@@ -74,8 +75,10 @@ buildProcessOrFunctionSpec (A.Specification _ _ (A.Proc m _ args p)) route
 buildProcessOrFunctionSpec (A.Specification _ _ (A.Function m _ _ args es)) route
   = let funcRoute = (route33 route A.Specification) in
     case es of
-      Left sel -> addNewSubProcFunc m args (Right (sel, route55 funcRoute A.Function @-> (\f (Left e) -> f e >>* Left))) (route45 funcRoute A.Function)
+      Left sel -> addNewSubProcFunc m args (Right (sel, route55 funcRoute A.Function @-> (Route
-      Right p -> addNewSubProcFunc m args (Left (p, route55 funcRoute A.Function @-> (\f (Right p) -> f p >>* Right))) (route45 funcRoute A.Function)
+        [0] $ \f (Left e) -> f e >>* Left))) (route45 funcRoute A.Function)
+      Right p -> addNewSubProcFunc m args (Left (p, route55 funcRoute A.Function @-> (Route
+        [0] $ \f (Right p) -> f p >>* Right))) (route45 funcRoute A.Function)
 buildProcessOrFunctionSpec _ _ = return ()
 
 -- All the various types of Structured (SEQ, PAR, ALT, IF, CASE, input-CASE, VALOF) deal with their nodes so differently
@@ -402,7 +405,7 @@ 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 (0, 0, ([],[]), [], []) $ flip runReaderT funcs $ runErrorT $ buildStructuredAST s id
+  = do res <- flip runStateT (0, 0, ([],[]), [], []) $ flip runReaderT funcs $ runErrorT $ buildStructuredAST s routeIdentity
        return $ case res of
                   (Left err,_) -> Left err
                   (Right _,(_,_,(nodes, edges),roots,terminators))
@@ -413,7 +416,7 @@ 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 (0, 0, ([],[]), [], []) $ flip runReaderT funcs $ runErrorT $ buildStructuredSeq s id
+  = do res <- flip runStateT (0, 0, ([],[]), [], []) $ flip runReaderT funcs $ runErrorT $ buildStructuredSeq s routeIdentity
        return $ case res of
                   (Left err,_) -> Left err
                   (Right (root,_),(_,_,(nodes, edges),roots, terminators))

flow/FlowGraphTest.hs

@@ -35,6 +35,7 @@ import Test.QuickCheck
 
 import qualified AST as A
 import FlowGraph
+import GenericUtils
 import Metadata
 import PrettyShow
 import TestFramework
@@ -753,12 +754,12 @@ pickFuncId g = map (applyFunc . getFunc) (labNodes g)
   where
     getFunc (_,n) = getNodeFunc n
     
-    applyFunc (AlterAlternative f) = f return
+    applyFunc (AlterAlternative f) = routeModify f return
-    applyFunc (AlterProcess f) = f return
+    applyFunc (AlterProcess f) = routeModify f return
-    applyFunc (AlterExpression f) = f return
+    applyFunc (AlterExpression f) = routeModify f return
-    applyFunc (AlterExpressionList f) = f return
+    applyFunc (AlterExpressionList f) = routeModify f return
-    applyFunc (AlterReplicator f) = f return
+    applyFunc (AlterReplicator f) = routeModify f return
-    applyFunc (AlterSpec f) = f return
+    applyFunc (AlterSpec f) = routeModify f return
     applyFunc (AlterNothing) = return
 
 -- | Given a flow-graph, it returns a list of the meta-tag replacement alteration functions,
@@ -770,12 +771,12 @@ pickFuncRep gr = Map.fromList $ filter ((/= emptyMeta) . fst) $ map (helpApplyFu
     
     helpApplyFunc (m,f) = (m, applyFunc (m,f))
     
-    applyFunc (m,AlterAlternative f) = f (g m)
+    applyFunc (m,AlterAlternative f) = routeModify f (g m)
-    applyFunc (m,AlterProcess f) = f (g m)
+    applyFunc (m,AlterProcess f) = routeModify f (g m)
-    applyFunc (m,AlterExpression f) = f (g m)
+    applyFunc (m,AlterExpression f) = routeModify f (g m)
-    applyFunc (m,AlterExpressionList f) = f (g m)
+    applyFunc (m,AlterExpressionList f) = routeModify f (g m)
-    applyFunc (m,AlterReplicator f) = f (g m)
+    applyFunc (m,AlterReplicator f) = routeModify f (g m)
-    applyFunc (m,AlterSpec f) = f (g m)
+    applyFunc (m,AlterSpec f) = routeModify f (g m)
     applyFunc (m,AlterNothing) = return
     
     g m = gmapM (mkM $ replaceM m (replaceMeta m))

flow/FlowUtils.hs

@@ -25,6 +25,7 @@ import Data.Generics
 import Data.Graph.Inductive hiding (run)
 
 import qualified AST as A
+import GenericUtils
 import Metadata
 import TreeUtils
 import Utils
@@ -42,13 +43,10 @@ data EdgeLabel = ESeq (Maybe Bool) | EStartPar Int | EEndPar Int deriving (Show,
 
 -- | A type used to build up tree-modifying functions.  When given an inner modification function,
 -- it returns a modification function for the whole tree.  The functions are monadic, to
--- provide flexibility; you can always use the Identity monad.
+-- provide flexibility; you can always use the Identity monad.  The type parameter
-type ASTModifier m inner structType = (inner -> m inner) -> (A.Structured structType -> m (A.Structured structType))
+-- m is left-over from when the monad used to be specific (now it can be any monad,
-
+-- using the mechanisms of Route) but it helps with code clarity
--- | An operator for combining ASTModifier functions as you walk the tree.
+type ASTModifier m inner structType = Route inner (A.Structured structType)
--- While its implementation is simple, it adds clarity to the code.
-(@->) :: ASTModifier m outer b -> ((inner -> m inner) -> (outer -> m outer)) -> ASTModifier m inner b
-(@->) = (.)
 
 -- | A choice of AST altering functions built on ASTModifier.
 data AlterAST m structType = 
@@ -217,18 +215,6 @@ addParEdges usePI (s,e) pairs
     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
-
-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
-  = do let (pre,x,suf) = getN n xs
-       x' <- f x
-       return (pre ++ [x'] ++ suf)
-
 mapMR :: forall inner mAlter mLabel label retType structType. (Monad mLabel, Monad mAlter) =>
   ASTModifier mAlter [inner] structType ->
   (inner -> ASTModifier mAlter inner structType -> GraphMaker mLabel mAlter label structType retType) ->
@@ -262,52 +248,3 @@ joinPairs m nodes = do sequence_ $ mapPairs (\(_,s) (e,_) -> addEdge (ESeq
                          Nothing) s e) nodes
                        return (fst (head nodes), snd (last nodes))
 
-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
-
-decomp23 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => (a0 -> a1 -> a2 -> a) -> (a1 -> m a1) -> (a -> m a)
-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
-
-route22 :: (Monad m, Data a, Typeable a0, Typeable a1) => ASTModifier m a b -> (a0 -> a1 -> a) -> ASTModifier m a1 b
-route22 route con = route @-> (decomp22 con)
-
-route23 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => ASTModifier m a b -> (a0 -> a1 -> a2 -> a) -> ASTModifier m a1 b
-route23 route con = route @-> (decomp23 con)
-
-route33 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => ASTModifier m a b -> (a0 -> a1 -> a2 -> a) -> ASTModifier m a2 b
-route33 route con = route @-> (decomp33 con)
-
-route34 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
-  ASTModifier m a b -> (a0 -> a1 -> a2 -> a3 -> a) -> ASTModifier m a2 b
-route34 route con = route @-> (decomp34 con)
-
-route44 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
-  ASTModifier m a b -> (a0 -> a1 -> a2 -> a3 -> a) -> ASTModifier m a3 b
-route44 route con = route @-> (decomp44 con)
-
-route45 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
-  ASTModifier m a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> ASTModifier m a3 b
-route45 route con = route @-> (decomp45 con)
-
-route55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
-  ASTModifier m a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> ASTModifier m a4 b
-route55 route con = route @-> (decomp55 con)

transformations/ImplicitMobility.hs

@@ -32,6 +32,7 @@ import Errors
 import FlowAlgorithms
 import FlowGraph
 import FlowUtils
+import GenericUtils
 import Metadata
 import Pass
 import Types
@@ -40,7 +41,7 @@ import Utils
 
 effectDecision :: Var -> Decision -> AlterAST PassM () -> A.AST -> PassM A.AST
 effectDecision _ Move _ = return -- Move is the default
-effectDecision targetVar Copy (AlterProcess wrapper) = wrapper alterProc
+effectDecision targetVar Copy (AlterProcess wrapper) = routeModify wrapper alterProc
   where
     derefExp :: A.Expression -> PassM A.Expression
     derefExp e