diff --git a/common/GenericUtils.hs b/common/GenericUtils.hs index 63305e2..63cc2a1 100644 --- a/common/GenericUtils.hs +++ b/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) diff --git a/flow/FlowGraph.hs b/flow/FlowGraph.hs index 1d8c28a..f5a916f 100644 --- a/flow/FlowGraph.hs +++ b/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) - Right p -> addNewSubProcFunc m args (Left (p, route55 funcRoute A.Function @-> (\f (Right p) -> f p >>* Right))) (route45 funcRoute A.Function) + Left sel -> addNewSubProcFunc m args (Right (sel, route55 funcRoute A.Function @-> (Route + [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)) diff --git a/flow/FlowGraphTest.hs b/flow/FlowGraphTest.hs index 7910c68..8d91968 100644 --- a/flow/FlowGraphTest.hs +++ b/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 (AlterProcess f) = f return - applyFunc (AlterExpression f) = f return - applyFunc (AlterExpressionList f) = f return - applyFunc (AlterReplicator f) = f return - applyFunc (AlterSpec f) = f return + applyFunc (AlterAlternative f) = routeModify f return + applyFunc (AlterProcess f) = routeModify f return + applyFunc (AlterExpression f) = routeModify f return + applyFunc (AlterExpressionList f) = routeModify f return + applyFunc (AlterReplicator f) = routeModify 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,AlterProcess f) = f (g m) - applyFunc (m,AlterExpression f) = f (g m) - applyFunc (m,AlterExpressionList f) = f (g m) - applyFunc (m,AlterReplicator f) = f (g m) - applyFunc (m,AlterSpec f) = f (g m) + applyFunc (m,AlterAlternative f) = routeModify f (g m) + applyFunc (m,AlterProcess f) = routeModify f (g m) + applyFunc (m,AlterExpression f) = routeModify f (g m) + applyFunc (m,AlterExpressionList f) = routeModify f (g m) + applyFunc (m,AlterReplicator f) = routeModify f (g m) + applyFunc (m,AlterSpec f) = routeModify f (g m) applyFunc (m,AlterNothing) = return g m = gmapM (mkM $ replaceM m (replaceMeta m)) diff --git a/flow/FlowUtils.hs b/flow/FlowUtils.hs index aa4f520..72cff63 100644 --- a/flow/FlowUtils.hs +++ b/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. -type ASTModifier m inner structType = (inner -> m inner) -> (A.Structured structType -> m (A.Structured structType)) - --- | An operator for combining ASTModifier functions as you walk the tree. --- 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 -(@->) = (.) +-- provide flexibility; you can always use the Identity monad. The type parameter +-- 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 +type ASTModifier m inner structType = Route inner (A.Structured structType) -- | 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) diff --git a/transformations/ImplicitMobility.hs b/transformations/ImplicitMobility.hs index 9ce58f4..bbdf1bb 100644 --- a/transformations/ImplicitMobility.hs +++ b/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