suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Neil Brown 2008-11-10 14:01:30 +00:00
parent 8405c646e3
commit dc030acabe
5 changed files with 83 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
common/GenericUtils.hs
View File

@ -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)

11
flow/FlowGraph.hs
View File

@ -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))

25
flow/FlowGraphTest.hs
View File

@ -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))

73
flow/FlowUtils.hs
View File

@ -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)

3
transformations/ImplicitMobility.hs
View File

@ -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