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

Reworked Polyplate to have a simpler way of expressing opsets, and also simplified PolyplateM and PolyplateMRoute

Browse Source
This commit is contained in:
Neil Brown 2009-05-06 11:32:19 +00:00
parent efa5c57fd0
commit 44eabe4baa
21 changed files with 292 additions and 294 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
backends/BackendPasses.hs
View File

@ -99,7 +99,7 @@ removeUnneededDirections
_ -> diePC m $ formatCode "Direction applied to non-channel type: %" t _ -> diePC m $ formatCode "Direction applied to non-channel type: %" t
doVariable v = return v doVariable v = return v
type AllocMobileOps = ExtOpMSP BaseOp `ExtOpMP` A.Process type AllocMobileOps = ExtOpMS BaseOpM `ExtOpMP` A.Process
-- | Pulls up any initialisers for mobile allocations. I think, after all the -- | Pulls up any initialisers for mobile allocations. I think, after all the
-- other passes have run, the only place these initialisers should be left is in -- other passes have run, the only place these initialisers should be left is in
@ -107,8 +107,8 @@ type AllocMobileOps = ExtOpMSP BaseOp `ExtOpMP` A.Process
pullAllocMobile :: PassOnOps AllocMobileOps pullAllocMobile :: PassOnOps AllocMobileOps
pullAllocMobile = cOnlyPass "Pull up mobile initialisers" [] [] recurse pullAllocMobile = cOnlyPass "Pull up mobile initialisers" [] [] recurse
where where
ops :: AllocMobileOps ops :: AllocMobileOps PassM
ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doProcess ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doProcess
recurse :: RecurseM PassM AllocMobileOps recurse :: RecurseM PassM AllocMobileOps
recurse = makeRecurseM ops recurse = makeRecurseM ops
@ -318,7 +318,7 @@ findVarSizes skip (A.VariableSizes m v)
mn <- getSizes m (A.VariableSizes m v) es mn <- getSizes m (A.VariableSizes m v) es
return $ Just (mn, fmap (A.Variable m) mn, es) return $ Just (mn, fmap (A.Variable m) mn, es)
type DeclSizeOps = ExtOpM SizesM (ExtOpMS SizesM BaseOp) A.Process type DeclSizeOps = A.Process :-* ExtOpMS BaseOpM
-- | Declares a _sizes array for every array, statically sized or dynamically sized. -- | Declares a _sizes array for every array, statically sized or dynamically sized.
-- For each record type it declares a _sizes array too. -- For each record type it declares a _sizes array too.
@ -333,8 +333,8 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays"
return t' return t'
)) ))
where where
ops :: DeclSizeOps ops :: DeclSizeOps SizesM
ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doProcess ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doProcess
recurse :: RecurseM SizesM DeclSizeOps recurse :: RecurseM SizesM DeclSizeOps
recurse = makeRecurseM ops recurse = makeRecurseM ops
@ -424,8 +424,8 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays"
lit = A.ArrayListLiteral m $ A.Several m $ map (A.Only m) es lit = A.ArrayListLiteral m $ A.Several m $ map (A.Only m) es
t = A.Array [A.Dimension $ makeConstant m (length es)] A.Int t = A.Array [A.Dimension $ makeConstant m (length es)] A.Int
doStructured :: (Data a, PolyplateM (A.Structured a) DeclSizeOps () SizesM doStructured :: (Data a, PolyplateM (A.Structured a) DeclSizeOps BaseOpM
, PolyplateM (A.Structured a) () DeclSizeOps SizesM) , PolyplateM (A.Structured a) BaseOpM DeclSizeOps)
=> (A.Structured a) -> SizesM (A.Structured a) => (A.Structured a) -> SizesM (A.Structured a)
doStructured str@(A.Spec m sp@(A.Specification m' n spec) s) doStructured str@(A.Spec m sp@(A.Specification m' n spec) s)
= do t <- typeOfSpec spec = do t <- typeOfSpec spec

13
checks/Check.hs
View File

@ -515,9 +515,7 @@ checkInitVar = forAnyFlowNode
warnP m WarnUninitialisedVariable $ "Variable(s) read from are not written to before-hand: " ++ vars warnP m WarnUninitialisedVariable $ "Variable(s) read from are not written to before-hand: " ++ vars
findAllProcess :: forall t m a. (Data t, Monad m, findAllProcess :: forall t m a. (Data t, Monad m,
PolyplateMRoute (A.Structured t) (OneOpMRoute (State [(A.Process, Route A.Process (A.Structured t))]) A.Process PolyplateMRoute (A.Structured t) (OneOpMRoute A.Process) BaseOpMRoute)
(A.Structured t))
() (State [(A.Process, Route A.Process (A.Structured t))]) (A.Structured t))
=> (A.Process -> Bool) -> FlowGraph' m a t -> A.Structured t -> [(A.Process, a)] => (A.Process -> Bool) -> FlowGraph' m a t -> A.Structured t -> [(A.Process, a)]
findAllProcess f g t = Map.elems $ Map.intersectionWith (,) astMap nodeMap findAllProcess f g t = Map.elems $ Map.intersectionWith (,) astMap nodeMap
where where
@ -533,9 +531,7 @@ findAllProcess f g t = Map.elems $ Map.intersectionWith (,) astMap nodeMap
_ -> Nothing _ -> Nothing
checkParAssignUsage :: forall m t. (CSMR m, Die m, MonadIO m, Data t, checkParAssignUsage :: forall m t. (CSMR m, Die m, MonadIO m, Data t,
PolyplateMRoute (A.Structured t) (OneOpMRoute (State [(A.Process, Route A.Process (A.Structured t))]) A.Process PolyplateMRoute (A.Structured t) (OneOpMRoute A.Process) BaseOpMRoute
(A.Structured t))
() (State [(A.Process, Route A.Process (A.Structured t))]) (A.Structured t)
) => FlowGraph' m (BK, UsageLabel) t -> A.Structured t -> m () ) => FlowGraph' m (BK, UsageLabel) t -> A.Structured t -> m ()
checkParAssignUsage g = mapM_ checkParAssign . findAllProcess isParAssign g checkParAssignUsage g = mapM_ checkParAssign . findAllProcess isParAssign g
where where
@ -556,9 +552,8 @@ checkParAssignUsage g = mapM_ checkParAssign . findAllProcess isParAssign g
$ processVarW v Nothing] | v <- vs] $ processVarW v Nothing] | v <- vs]
checkProcCallArgsUsage :: forall m t. (CSMR m, Die m, MonadIO m, Data t, checkProcCallArgsUsage :: forall m t. (CSMR m, Die m, MonadIO m, Data t,
PolyplateMRoute (A.Structured t) (OneOpMRoute (State [(A.Process, Route A.Process (A.Structured t))]) A.Process PolyplateMRoute (A.Structured t) (OneOpMRoute A.Process)
(A.Structured t)) BaseOpMRoute
() (State [(A.Process, Route A.Process (A.Structured t))]) (A.Structured t)
) => ) =>
FlowGraph' m (BK, UsageLabel) t -> A.Structured t -> m () FlowGraph' m (BK, UsageLabel) t -> A.Structured t -> m ()
checkProcCallArgsUsage g = mapM_ checkArgs . findAllProcess isProcCall g checkProcCallArgsUsage g = mapM_ checkArgs . findAllProcess isProcCall g

95
checks/CheckFramework.hs
View File

@ -260,15 +260,15 @@ forAnyParItems = undefined
-- | This function currently only supports one type -- | This function currently only supports one type
forAnyASTTopDown :: forall a. forAnyASTTopDown :: forall a.
(PolyplateMRoute A.AST ((a, Route a A.AST) -> RestartT CheckOptM a, ()) () (RestartT CheckOptM) A.AST (PolyplateMRoute A.AST (a :-@ BaseOpMRoute) BaseOpMRoute
,PolyplateMRoute a () ((a, Route a A.AST) -> RestartT CheckOptM a, ()) (RestartT CheckOptM) A.AST ,PolyplateMRoute a BaseOpMRoute (a :-@ BaseOpMRoute)
) => ) =>
(a -> CheckOptASTM a ()) -> CheckOptM () (a -> CheckOptASTM a ()) -> CheckOptM ()
forAnyASTTopDown origF = CheckOptM $ do forAnyASTTopDown origF = CheckOptM $ do
tr <- get >>* ast tr <- get >>* ast
doTree ops transformMRoute tr doTree ops transformMRoute tr
where where
ops = baseOp `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM origF) ops = baseOpMRoute `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM origF)
forAnyASTStructTopDown :: (forall a. Data a => (A.Structured a -> CheckOptASTM (A.Structured forAnyASTStructTopDown :: (forall a. Data a => (A.Structured a -> CheckOptASTM (A.Structured
a) ())) -> CheckOptM () a) ())) -> CheckOptM ()
@ -277,7 +277,7 @@ forAnyASTStructTopDown origF = CheckOptM $ do
doTree ops transformMRoute tr doTree ops transformMRoute tr
where where
ops ops
= baseOp = baseOpMRoute
`extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Variant -> CheckOptASTM (A.Structured A.Variant) ())) `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Variant -> CheckOptASTM (A.Structured A.Variant) ()))
`extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Process -> CheckOptASTM (A.Structured A.Process) ())) `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Process -> CheckOptASTM (A.Structured A.Process) ()))
`extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Option -> CheckOptASTM (A.Structured A.Option) ())) `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Option -> CheckOptASTM (A.Structured A.Option) ()))
@ -286,23 +286,21 @@ forAnyASTStructTopDown origF = CheckOptM $ do
`extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Alternative -> CheckOptASTM (A.Structured A.Alternative) ())) `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured A.Alternative -> CheckOptASTM (A.Structured A.Alternative) ()))
`extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured () -> CheckOptASTM (A.Structured ()) ())) `extOpMRoute` (makeTopDownMRoute ops $ keepApplying $ deCheckOptASTM (origF :: A.Structured () -> CheckOptASTM (A.Structured ()) ()))
type AccumOp b a = (A.Structured a, Route (A.Structured a) A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) (A.Structured a) type ExtAcc a b = b :-@ a
type ExtAcc a b = (b, a)
type AccumOps b = type AccumOps b =
BaseOp BaseOpMRoute
`ExtAcc` AccumOp b A.Variant `ExtAcc` A.Structured A.Variant
`ExtAcc` AccumOp b A.Process `ExtAcc` A.Structured A.Process
`ExtAcc` AccumOp b A.Option `ExtAcc` A.Structured A.Option
`ExtAcc` AccumOp b A.ExpressionList `ExtAcc` A.Structured A.ExpressionList
`ExtAcc` AccumOp b A.Choice `ExtAcc` A.Structured A.Choice
`ExtAcc` AccumOp b A.Alternative `ExtAcc` A.Structured A.Alternative
`ExtAcc` AccumOp b () `ExtAcc` A.Structured ()
`ExtAcc` ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b) `ExtAcc` b
type SingleOps b type SingleOps b
= ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b, ()) = b :-@ BaseOpMRoute
type AccumMap b = Map.Map [Int] b type AccumMap b = Map.Map [Int] b
@ -316,30 +314,30 @@ filterSub r = Map.filterWithKey (\k _ -> not $ r `isPrefixOf` k)
-- I know the constraints here look horrendous, but it's really just three groups. -- I know the constraints here look horrendous, but it's really just three groups.
forAnyASTStructBottomUpAccum :: forall b. (Data b, forAnyASTStructBottomUpAccum :: forall b. (Data b,
-- Allow us to descend into the AST with our full set of ops: -- Allow us to descend into the AST with our full set of ops:
PolyplateMRoute A.AST (AccumOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute A.AST (AccumOps b) BaseOpMRoute,
-- Allow us to recurse into each Structured item (and b) with our full set of -- Allow us to recurse into each Structured item (and b) with our full set of
-- ops: -- ops:
PolyplateMRoute (A.Structured A.Variant) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.Variant) BaseOpMRoute (AccumOps b),
PolyplateMRoute (A.Structured A.Process) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.Process) BaseOpMRoute (AccumOps b),
PolyplateMRoute (A.Structured A.Option) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.Option) BaseOpMRoute (AccumOps b),
PolyplateMRoute (A.Structured A.ExpressionList) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.ExpressionList) BaseOpMRoute (AccumOps b),
PolyplateMRoute (A.Structured A.Choice) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.Choice) BaseOpMRoute (AccumOps b),
PolyplateMRoute (A.Structured A.Alternative) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.Alternative) BaseOpMRoute (AccumOps b),
PolyplateMRoute (A.Structured ()) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured ()) BaseOpMRoute (AccumOps b),
PolyplateMRoute b () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute b BaseOpMRoute (AccumOps b),
-- Allow us to descend into each Structured item with just our ops for -- Allow us to descend into each Structured item with just our ops for
-- b, when our accumulated stuff becomes invalidated -- b, when our accumulated stuff becomes invalidated
PolyplateMRoute (A.Structured A.Variant) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.Variant) (SingleOps b) BaseOpMRoute,
PolyplateMRoute (A.Structured A.Process) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.Process) (SingleOps b) BaseOpMRoute,
PolyplateMRoute (A.Structured A.Option) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.Option) (SingleOps b) BaseOpMRoute,
PolyplateMRoute (A.Structured A.ExpressionList) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.ExpressionList) (SingleOps b) BaseOpMRoute,
PolyplateMRoute (A.Structured A.Choice) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.Choice) (SingleOps b) BaseOpMRoute,
PolyplateMRoute (A.Structured A.Alternative) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured A.Alternative) (SingleOps b) BaseOpMRoute,
PolyplateMRoute (A.Structured ()) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST, PolyplateMRoute (A.Structured ()) (SingleOps b) BaseOpMRoute,
-- For b, we will recurse, not descend: -- For b, we will recurse, not descend:
PolyplateMRoute b () (SingleOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST PolyplateMRoute b BaseOpMRoute (SingleOps b)
) => ) =>
(forall a. Data a => (A.Structured a) -> CheckOptASTM' [b] (A.Structured a) ()) -> CheckOptM () (forall a. Data a => (A.Structured a) -> CheckOptASTM' [b] (A.Structured a) ()) -> CheckOptM ()
@ -347,12 +345,12 @@ forAnyASTStructBottomUpAccum origF = CheckOptM $ do
tr <- get >>* ast tr <- get >>* ast
doTree ops (\x y z -> flip evalStateT (Map.empty :: AccumMap b) $ transformMRoute x y z) tr doTree ops (\x y z -> flip evalStateT (Map.empty :: AccumMap b) $ transformMRoute x y z) tr
where where
ops :: AccumOps b ops :: AccumOps b (StateT (AccumMap b) (RestartT CheckOptM)) A.AST
ops = applyAccum (undefined::b) allF ops = applyAccum (undefined::b) allF
keepApplying' :: keepApplying' ::
PolyplateMRoute t ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b, ()) PolyplateMRoute t (b :-@ BaseOpMRoute)
() (StateT (AccumMap b) (RestartT CheckOptM)) A.AST BaseOpMRoute
=> ((t, Route t A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) (Either t t)) -> => ((t, Route t A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) (Either t t)) ->
((t, Route t A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) t) ((t, Route t A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) t)
keepApplying' f xr = do x' <- f xr keepApplying' f xr = do x' <- f xr
@ -361,13 +359,12 @@ forAnyASTStructBottomUpAccum origF = CheckOptM $ do
Left y -> do -- remove all sub-items from state, Left y -> do -- remove all sub-items from state,
-- and then scan the item anew: -- and then scan the item anew:
modify $ filterSub (routeId $ snd xr) modify $ filterSub (routeId $ snd xr)
transformMRoute (applyAccum (undefined::b) ()) () (y, snd xr) transformMRoute (applyAccum (undefined::b) BaseOpMRoute) BaseOpMRoute (y, snd xr)
keepApplying' f (y, snd xr) keepApplying' f (y, snd xr)
wrap :: forall a. (Data a, wrap :: forall a. (Data a,
PolyplateMRoute (A.Structured a) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST PolyplateMRoute (A.Structured a) BaseOpMRoute (AccumOps b)
, PolyplateMRoute (A.Structured a) ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b, ()) , PolyplateMRoute (A.Structured a) (b :-@ BaseOpMRoute) BaseOpMRoute
() (StateT (AccumMap b) (RestartT CheckOptM)) A.AST
) => ((A.Structured a, Route (A.Structured a) A.AST, [b]) -> RestartT ) => ((A.Structured a, Route (A.Structured a) A.AST, [b]) -> RestartT
CheckOptM (Either (A.Structured a) (A.Structured a))) -> (A.Structured a, Route (A.Structured CheckOptM (Either (A.Structured a) (A.Structured a))) -> (A.Structured a, Route (A.Structured
a) A.AST) -> StateT (AccumMap b) (RestartT a) A.AST) -> StateT (AccumMap b) (RestartT
@ -376,7 +373,7 @@ forAnyASTStructBottomUpAccum origF = CheckOptM $ do
(routeId y) z)) (routeId y) z))
allF allF
= baseOp = baseOpMRoute
`extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Variant) -> `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Variant) ->
CheckOptASTM' [b] (A.Structured A.Variant) ())) CheckOptASTM' [b] (A.Structured A.Variant) ()))
`extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Process) -> `extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Process) ->
@ -400,11 +397,11 @@ type TransFuncS acc b a = (a, Route a b) -> StateT acc (RestartT CheckOptM) a
-- location to begin at and an AST, transforms the tree. Handles any restarts -- location to begin at and an AST, transforms the tree. Handles any restarts
-- that are requested. -- that are requested.
doTree :: ops -> doTree :: ops ->
(ops -> () -> (A.AST, Route A.AST A.AST) -> RestartT CheckOptM A.AST) -> A.AST -> StateT CheckOptData PassM () (ops -> BaseOpMRoute m outer -> (A.AST, Route A.AST A.AST) -> RestartT CheckOptM A.AST) -> A.AST -> StateT CheckOptData PassM ()
-- This line applies "apply" to the first thing of the right type in -- This line applies "apply" to the first thing of the right type in
-- the given AST; from there, ops recurses for itself -- the given AST; from there, ops recurses for itself
doTree ops trans tr doTree ops trans tr
= do x <- deCheckOptM (getRestartT (trans ops () (tr, identityRoute) >> return ())) = do x <- deCheckOptM (getRestartT (trans ops BaseOpMRoute (tr, identityRoute) >> return ()))
case x of case x of
Left _ -> do -- Restart Left _ -> do -- Restart
tr' <- get >>* ast tr' <- get >>* ast
@ -412,15 +409,15 @@ doTree ops trans tr
Right _ -> return () Right _ -> return ()
applyAccum :: forall t ops. applyAccum :: forall t ops.
PolyplateMRoute t () ((t, Route t A.AST) -> StateT (AccumMap t) (RestartT CheckOptM) t, ops) PolyplateMRoute t BaseOpMRoute (t :-@ ops)
=> t -> ops (StateT (AccumMap t) (RestartT CheckOptM)) A.AST -> (t :-@ ops)
(StateT (AccumMap t) (RestartT CheckOptM)) A.AST (StateT (AccumMap t) (RestartT CheckOptM)) A.AST
=> t -> ops -> ((t, Route t A.AST) -> StateT (AccumMap t) (RestartT CheckOptM) t, ops)
applyAccum _ ops = ops' applyAccum _ ops = ops'
where where
ops' :: ((t, Route t A.AST) -> StateT (AccumMap t) (RestartT CheckOptM) t, ops) ops' :: (t :-@ ops) (StateT (AccumMap t) (RestartT CheckOptM)) A.AST
ops' = (accum, ops) ops' = accum :-@ ops
accum xr = do x' <- transformMRoute () ops' xr accum xr = do x' <- transformMRoute BaseOpMRoute ops' xr
modify $ Map.insert (routeId $ snd xr) x' modify $ Map.insert (routeId $ snd xr) x'
return x' return x'

16
frontends/OccamCheckTypes.hs
View File

@ -49,14 +49,14 @@ ok = return ()
-- This is actually a series of smaller passes that check particular types -- This is actually a series of smaller passes that check particular types
-- inside the AST, but it doesn't really make sense to split it up. -- inside the AST, but it doesn't really make sense to split it up.
checkTypes :: checkTypes ::
(PolyplateM t (OneOpM PassM A.Variable) () PassM (PolyplateM t (OneOpM A.Variable) BaseOpM
,PolyplateM t (OneOpM PassM A.Expression) () PassM ,PolyplateM t (OneOpM A.Expression) BaseOpM
,PolyplateM t (OneOpM PassM A.SpecType) () PassM ,PolyplateM t (OneOpM A.SpecType) BaseOpM
,PolyplateM t (OneOpM PassM A.Process) () PassM ,PolyplateM t (OneOpM A.Process) BaseOpM
,PolyplateM t () (OneOpM PassM A.Variable) PassM ,PolyplateM t BaseOpM (OneOpM A.Variable)
,PolyplateM t () (OneOpM PassM A.Expression) PassM ,PolyplateM t BaseOpM (OneOpM A.Expression)
,PolyplateM t () (OneOpM PassM A.SpecType) PassM ,PolyplateM t BaseOpM (OneOpM A.SpecType)
,PolyplateM t () (OneOpM PassM A.Process) PassM ,PolyplateM t BaseOpM (OneOpM A.Process)
) => Pass t ) => Pass t
checkTypes = occamOnlyPass "Check types" checkTypes = occamOnlyPass "Check types"
[Prop.inferredTypesRecorded, Prop.ambiguitiesResolved] [Prop.inferredTypesRecorded, Prop.ambiguitiesResolved]

30
frontends/OccamInferTypes.hs
View File

@ -163,7 +163,7 @@ data InferTypeState = InferTypeState
type InferTypeM = StateT InferTypeState PassM type InferTypeM = StateT InferTypeState PassM
type ExtOpMI ops t = ExtOpM InferTypeM ops t type ExtOpMI ops t = t :-* ops
--{{{ type contexts --{{{ type contexts
@ -193,7 +193,7 @@ getTypeContext
-- I can't put this in the where clause of inferTypes, so it has to be out -- I can't put this in the where clause of inferTypes, so it has to be out
-- here. It should be the type of ops inside the inferTypes function below. -- here. It should be the type of ops inside the inferTypes function below.
type InferTypeOps type InferTypeOps
= ExtOpMS InferTypeM BaseOp = ExtOpMS BaseOpM
`ExtOpMI` A.Expression `ExtOpMI` A.Expression
`ExtOpMI` A.Dimension `ExtOpMI` A.Dimension
`ExtOpMI` A.Subscript `ExtOpMI` A.Subscript
@ -212,8 +212,8 @@ inferTypes = occamOnlyPass "Infer types"
[Prop.inferredTypesRecorded] [Prop.inferredTypesRecorded]
(flip evalStateT (InferTypeState [] []) . recurse) (flip evalStateT (InferTypeState [] []) . recurse)
where where
ops :: InferTypeOps ops :: InferTypeOps InferTypeM
ops = baseOp ops = baseOpM
`extOpMS` (ops, doStructured) `extOpMS` (ops, doStructured)
`extOpM` doExpression `extOpM` doExpression
`extOpM` doDimension `extOpM` doDimension
@ -365,14 +365,14 @@ inferTypes = occamOnlyPass "Infer types"
= typeEqForOp t t' = typeEqForOp t t'
typeEqForOp t t' = t == t' typeEqForOp t t' = t == t'
doActuals :: (PolyplateM a InferTypeOps () InferTypeM, Data a) => Meta -> A.Name -> [A.Formal] -> doActuals :: (PolyplateM a InferTypeOps BaseOpM, Data a) => Meta -> A.Name -> [A.Formal] ->
(Meta -> A.Direction -> Infer a, A.Type -> Infer a) -> Infer [a] (Meta -> A.Direction -> Infer a, A.Type -> Infer a) -> Infer [a]
doActuals m n fs applyDir_Deref as doActuals m n fs applyDir_Deref as
= do lift $ checkActualCount m n fs as = do lift $ checkActualCount m n fs as
sequence [doActual m applyDir_Deref t a | (A.Formal _ t _, a) <- zip fs as] sequence [doActual m applyDir_Deref t a | (A.Formal _ t _, a) <- zip fs as]
-- First function directs, second function dereferences if needed -- First function directs, second function dereferences if needed
doActual :: (PolyplateM a InferTypeOps () InferTypeM, Data a) => doActual :: (PolyplateM a InferTypeOps BaseOpM, Data a) =>
Meta -> (Meta -> A.Direction -> Infer a, A.Type -> Infer a) -> A.Type -> Infer a Meta -> (Meta -> A.Direction -> Infer a, A.Type -> Infer a) -> A.Type -> Infer a
doActual m (applyDir, _) (A.ChanEnd dir _ _) a = recurse a >>= applyDir m dir doActual m (applyDir, _) (A.ChanEnd dir _ _) a = recurse a >>= applyDir m dir
doActual m (_, deref) t a = inTypeContext (Just t) $ recurse a >>= deref t doActual m (_, deref) t a = inTypeContext (Just t) $ recurse a >>= deref t
@ -458,8 +458,8 @@ inferTypes = occamOnlyPass "Infer types"
mp' <- recurse mp mp' <- recurse mp
return $ A.Variant m n iis' p' mp' return $ A.Variant m n iis' p' mp'
doStructured :: ( PolyplateM (A.Structured t) InferTypeOps () InferTypeM doStructured :: ( PolyplateM (A.Structured t) InferTypeOps BaseOpM
, PolyplateM (A.Structured t) () InferTypeOps InferTypeM , PolyplateM (A.Structured t) BaseOpM InferTypeOps
, Data t) => Infer (A.Structured t) , Data t) => Infer (A.Structured t)
doStructured (A.Spec mspec s@(A.Specification m n st) body) doStructured (A.Spec mspec s@(A.Specification m n st) body)
@ -470,8 +470,8 @@ inferTypes = occamOnlyPass "Infer types"
doStructured s = descend s doStructured s = descend s
-- The second parameter is a modifier (wrapper) for the descent into the body -- The second parameter is a modifier (wrapper) for the descent into the body
doSpecType :: ( PolyplateM (A.Structured t) InferTypeOps () InferTypeM doSpecType :: ( PolyplateM (A.Structured t) InferTypeOps BaseOpM
, PolyplateM (A.Structured t) () InferTypeOps InferTypeM , PolyplateM (A.Structured t) BaseOpM InferTypeOps
, Data t) => A.Name -> A.SpecType -> ReaderT (A.Structured t) InferTypeM , Data t) => A.Name -> A.SpecType -> ReaderT (A.Structured t) InferTypeM
(A.SpecType, InferTypeM (A.Structured a) -> InferTypeM (A.Structured a)) (A.SpecType, InferTypeM (A.Structured a) -> InferTypeM (A.Structured a))
doSpecType n st doSpecType n st
@ -663,19 +663,19 @@ inferTypes = occamOnlyPass "Infer types"
-- Also, to fit with the normal ops, we must do so in the PassM monad. -- Also, to fit with the normal ops, we must do so in the PassM monad.
-- Normally we would do this pass in a StateT monad, but to slip inside -- Normally we would do this pass in a StateT monad, but to slip inside
-- PassM, I've used an IORef instead. -- PassM, I've used an IORef instead.
findDir :: ( PolyplateM a InferTypeOps () InferTypeM findDir :: ( PolyplateM a InferTypeOps BaseOpM
, PolyplateM a () InferTypeOps InferTypeM , PolyplateM a BaseOpM InferTypeOps
) => A.Name -> a -> InferTypeM [A.Direction] ) => A.Name -> a -> InferTypeM [A.Direction]
findDir n x findDir n x
= do r <- liftIO $ newIORef [] = do r <- liftIO $ newIORef []
makeRecurseM (makeOps r) x makeRecurseM (makeOps r) x
liftIO $ readIORef r liftIO $ readIORef r
where where
makeOps :: IORef [A.Direction] -> InferTypeOps makeOps :: IORef [A.Direction] -> InferTypeOps InferTypeM
makeOps r = ops makeOps r = ops
where where
ops :: InferTypeOps ops :: InferTypeOps InferTypeM
ops = baseOp ops = baseOpM
`extOpMS` (ops, descend) `extOpMS` (ops, descend)
`extOpM` descend `extOpM` descend
`extOpM` descend `extOpM` descend

6
frontends/OccamPasses.hs
View File

@ -248,7 +248,7 @@ foldConstants = occamOnlyPass "Fold constants"
= do modifyName n (\nd -> nd { A.ndSpecType = st }) = do modifyName n (\nd -> nd { A.ndSpecType = st })
return s return s
type CheckConstantsOps = BaseOp `ExtOpMP` A.Type `ExtOpMP` A.Option type CheckConstantsOps = BaseOpM `ExtOpMP` A.Type `ExtOpMP` A.Option
`ExtOpMP` A.SpecType `ExtOpMP` A.SpecType
-- | Check that things that must be constant are. -- | Check that things that must be constant are.
@ -258,8 +258,8 @@ checkConstants = occamOnlyPass "Check mandatory constants"
[Prop.constantsChecked] [Prop.constantsChecked]
recurse recurse
where where
ops :: CheckConstantsOps ops :: CheckConstantsOps PassM
ops = baseOp `extOpM` doType `extOpM` doOption `extOpM` doSpecType ops = baseOpM `extOpM` doType `extOpM` doOption `extOpM` doSpecType
descend :: DescendM PassM CheckConstantsOps descend :: DescendM PassM CheckConstantsOps
descend = makeDescendM ops descend = makeDescendM ops

12
frontends/OccamPassesTest.hs
View File

@ -93,8 +93,8 @@ testFoldConstants = TestList
, test 48 (add var (add const one)) (add var three) , test 48 (add var (add const one)) (add var three)
] ]
where where
test :: (PolyplateM a (TwoOpM PassM A.Expression A.Specification) () PassM test :: (PolyplateM a (TwoOpM A.Expression A.Specification) BaseOpM
,PolyplateM a () (TwoOpM PassM A.Expression A.Specification) PassM ,PolyplateM a BaseOpM (TwoOpM A.Expression A.Specification)
,Data a) => Int -> a -> a -> Test ,Data a) => Int -> a -> a -> Test
test n orig exp = TestCase $ testPass ("testFoldConstants" ++ show n) test n orig exp = TestCase $ testPass ("testFoldConstants" ++ show n)
exp OccamPasses.foldConstants orig exp OccamPasses.foldConstants orig
@ -142,15 +142,15 @@ testCheckConstants = TestList
, testFail 33 (A.Option m [lit10, lit10, lit10, var] skip) , testFail 33 (A.Option m [lit10, lit10, lit10, var] skip)
] ]
where where
testOK :: (PolyplateM a OccamPasses.CheckConstantsOps () PassM testOK :: (PolyplateM a OccamPasses.CheckConstantsOps BaseOpM
,PolyplateM a () OccamPasses.CheckConstantsOps PassM ,PolyplateM a BaseOpM OccamPasses.CheckConstantsOps
,Show a, Data a) => Int -> a -> Test ,Show a, Data a) => Int -> a -> Test
testOK n orig testOK n orig
= TestCase $ testPass ("testCheckConstants" ++ show n) = TestCase $ testPass ("testCheckConstants" ++ show n)
orig OccamPasses.checkConstants orig orig OccamPasses.checkConstants orig
(return ()) (return ())
testFail :: (PolyplateM a OccamPasses.CheckConstantsOps () PassM testFail :: (PolyplateM a OccamPasses.CheckConstantsOps BaseOpM
,PolyplateM a () OccamPasses.CheckConstantsOps PassM ,PolyplateM a BaseOpM OccamPasses.CheckConstantsOps
,Show a, Data a) => Int -> a -> Test ,Show a, Data a) => Int -> a -> Test
testFail n orig testFail n orig
= TestCase $ testPassShouldFail ("testCheckConstants" ++ show n) = TestCase $ testPassShouldFail ("testCheckConstants" ++ show n)

32
frontends/OccamTypesTest.hs
View File

@ -505,28 +505,28 @@ testOccamTypes = TestList
--}}} --}}}
] ]
where where
testOK :: (PolyplateM a (OneOpM PassM A.Variable) () PassM testOK :: (PolyplateM a (OneOpM A.Variable) BaseOpM
,PolyplateM a (OneOpM PassM A.Expression) () PassM ,PolyplateM a (OneOpM A.Expression) BaseOpM
,PolyplateM a (OneOpM PassM A.SpecType) () PassM ,PolyplateM a (OneOpM A.SpecType) BaseOpM
,PolyplateM a (OneOpM PassM A.Process) () PassM ,PolyplateM a (OneOpM A.Process) BaseOpM
,PolyplateM a () (OneOpM PassM A.Variable) PassM ,PolyplateM a BaseOpM (OneOpM A.Variable)
,PolyplateM a () (OneOpM PassM A.Expression) PassM ,PolyplateM a BaseOpM (OneOpM A.Expression)
,PolyplateM a () (OneOpM PassM A.SpecType) PassM ,PolyplateM a BaseOpM (OneOpM A.SpecType)
,PolyplateM a () (OneOpM PassM A.Process) PassM ,PolyplateM a BaseOpM (OneOpM A.Process)
,Show a, Data a) => Int -> a -> Test ,Show a, Data a) => Int -> a -> Test
testOK n orig testOK n orig
= TestCase $ testPass ("testOccamTypes " ++ show n) = TestCase $ testPass ("testOccamTypes " ++ show n)
orig OccamTypes.checkTypes orig orig OccamTypes.checkTypes orig
startState startState
testFail :: (PolyplateM a (OneOpM PassM A.Variable) () PassM testFail :: (PolyplateM a (OneOpM A.Variable) BaseOpM
,PolyplateM a (OneOpM PassM A.Expression) () PassM ,PolyplateM a (OneOpM A.Expression) BaseOpM
,PolyplateM a (OneOpM PassM A.SpecType) () PassM ,PolyplateM a (OneOpM A.SpecType) BaseOpM
,PolyplateM a (OneOpM PassM A.Process) () PassM ,PolyplateM a (OneOpM A.Process) BaseOpM
,PolyplateM a () (OneOpM PassM A.Variable) PassM ,PolyplateM a BaseOpM (OneOpM A.Variable)
,PolyplateM a () (OneOpM PassM A.Expression) PassM ,PolyplateM a BaseOpM (OneOpM A.Expression)
,PolyplateM a () (OneOpM PassM A.SpecType) PassM ,PolyplateM a BaseOpM (OneOpM A.SpecType)
,PolyplateM a () (OneOpM PassM A.Process) PassM ,PolyplateM a BaseOpM (OneOpM A.Process)
,Show a, Data a) => Int -> a -> Test ,Show a, Data a) => Int -> a -> Test
testFail n orig testFail n orig
= TestCase $ testPassShouldFail ("testOccamTypes " ++ show n) = TestCase $ testPassShouldFail ("testOccamTypes " ++ show n)

20
frontends/RainTypes.hs
View File

@ -61,11 +61,11 @@ type RainTypeM = StateT RainTypeState PassM
type RainTypePassType = forall t. t -> StateT RainTypeState PassM t type RainTypePassType = forall t. t -> StateT RainTypeState PassM t
type RainTypeCheckOn a = forall t. PolyplateM t (OneOpM RainTypeM a) () RainTypeM type RainTypeCheckOn a = forall t. PolyplateM t (OneOpM a) BaseOpM
=> t -> RainTypeM () => t -> RainTypeM ()
type RainTypeCheckOn2 a b = forall t. type RainTypeCheckOn2 a b = forall t.
(PolyplateM t (TwoOpM RainTypeM a b) () RainTypeM (PolyplateM t (TwoOpM a b) BaseOpM
) => t -> RainTypeM () ) => t -> RainTypeM ()
@ -122,14 +122,14 @@ markUnify x y
performTypeUnification :: performTypeUnification ::
-- | A shorthand for prerequisites when you need to spell them out: -- | A shorthand for prerequisites when you need to spell them out:
(PolyplateM t (OneOpM RainTypeM A.Specification) () RainTypeM (PolyplateM t (OneOpM A.Specification) BaseOpM
,PolyplateM t (OneOpM RainTypeM A.Process) () RainTypeM ,PolyplateM t (OneOpM A.Process) BaseOpM
,PolyplateM t (OneOpM RainTypeM A.Expression) () RainTypeM ,PolyplateM t (OneOpM A.Expression) BaseOpM
,PolyplateM t (TwoOpM RainTypeM A.Process A.Expression) () RainTypeM ,PolyplateM t (TwoOpM A.Process A.Expression) BaseOpM
,PolyplateM t (TwoOpM RainTypeM A.Process A.Choice) () RainTypeM ,PolyplateM t (TwoOpM A.Process A.Choice) BaseOpM
,PolyplateM t (TwoOpM RainTypeM A.Process A.Alternative) () RainTypeM ,PolyplateM t (TwoOpM A.Process A.Alternative) BaseOpM
,PolyplateM t () (OneOpM PassM A.Type) PassM ,PolyplateM t BaseOpM (OneOpM A.Type)
,PolyplateM t (OneOpM PassM A.Type) () PassM ,PolyplateM t (OneOpM A.Type) BaseOpM
) => Pass t ) => Pass t
performTypeUnification = rainOnlyPass "Rain Type Checking" performTypeUnification = rainOnlyPass "Rain Type Checking"
([Prop.noInt] ++ Prop.agg_namesDone) ([Prop.noInt] ++ Prop.agg_namesDone)

18
pass/Pass.hs
View File

@ -97,21 +97,21 @@ instance Warn (ReaderT r PassM) where
-- against AST fragments of other types as well. -- against AST fragments of other types as well.
type PassType t = t -> PassM t type PassType t = t -> PassM t
type PassOnOpsM m ops type PassOnOpsM ops
= (PolyplateM t ops () m, PolyplateM t () ops m) => Pass t = (PolyplateM t ops BaseOpM, PolyplateM t BaseOpM ops) => Pass t
type PassOnOps ops = PassOnOpsM PassM ops type PassOnOps ops = PassOnOpsM ops
type PassASTOnOps ops type PassASTOnOps ops
= (PolyplateM A.AST ops () PassM, PolyplateM A.AST () ops PassM) => Pass A.AST = (PolyplateM A.AST ops BaseOpM, PolyplateM A.AST BaseOpM ops) => Pass A.AST
type PassTypeOnOps ops type PassTypeOnOps ops
= (PolyplateM t ops () PassM, PolyplateM t () ops PassM) => PassType t = (PolyplateM t ops BaseOpM, PolyplateM t BaseOpM ops) => PassType t
type PassOn t = PassOnOps (OneOpM PassM t) type PassOn t = PassOnOps (OneOpM t)
type PassOn2 s t = PassOnOps (TwoOpM PassM s t) type PassOn2 s t = PassOnOps (TwoOpM s t)
type PassOnM2 m s t = PassOnOpsM m (TwoOpM m s t) type PassOnM2 s t = PassOnOpsM (TwoOpM s t)
type PassTypeOn t = PassTypeOnOps (OneOpM PassM t) type PassTypeOn t = PassTypeOnOps (OneOpM t)
-- | A description of an AST-mangling pass. -- | A description of an AST-mangling pass.
data Pass t = Pass { data Pass t = Pass {

110
pass/Traversal.hs
View File

@ -51,77 +51,79 @@ type CheckM m t = t -> m ()
-- | As 'CheckM', but specialised for 'PassM'. -- | As 'CheckM', but specialised for 'PassM'.
type Check t = CheckM PassM t type Check t = CheckM PassM t
type ExtOpMP opT t = ExtOpM PassM opT t type ExtOpMP opT t = t :-* opT
type ExtOpMS m opT = type ExtOpMS opT =
(A.Structured () -> m (A.Structured ()), (A.Structured ()) :-*
(A.Structured A.Alternative -> m (A.Structured A.Alternative), (A.Structured A.Alternative) :-*
(A.Structured A.Choice -> m (A.Structured A.Choice), (A.Structured A.Choice) :-*
(A.Structured A.ExpressionList -> m (A.Structured A.ExpressionList), (A.Structured A.ExpressionList) :-*
(A.Structured A.Option -> m (A.Structured A.Option), (A.Structured A.Option) :-*
(A.Structured A.Process -> m (A.Structured A.Process), (A.Structured A.Process) :-*
(A.Structured A.Variant -> m (A.Structured A.Variant), (A.Structured A.Variant) :-*
opT))))))) opT
type ExtOpMSP opT = ExtOpMS PassM opT
type PassOnStruct = PassOnOps (ExtOpMSP BaseOp) type ExtOpMSP opT = ExtOpMS opT PassM
type PassASTOnStruct = PassASTOnOps (ExtOpMSP BaseOp)
class (PolyplateM (A.Structured a) () opsM m type PassOnStruct = PassOnOps (ExtOpMS BaseOpM)
,PolyplateM (A.Structured a) opsM () m type PassASTOnStruct = PassASTOnOps (ExtOpMS BaseOpM)
class (PolyplateM (A.Structured a) BaseOpM opsM
,PolyplateM (A.Structured a) opsM BaseOpM
,Data a ,Data a
,Monad m ,Monad m
) => ASTStructured a opsM m opsQ r ) => ASTStructured a opsM m opsQ r
instance (PolyplateM (A.Structured ()) () opsM m instance (PolyplateM (A.Structured ()) BaseOpM opsM
,PolyplateM (A.Structured ()) opsM () m ,PolyplateM (A.Structured ()) opsM BaseOpM
,Monad m) => ASTStructured () opsM m opsQ r ,Monad m) => ASTStructured () opsM m opsQ r
instance (PolyplateM (A.Structured A.Alternative) () opsM m instance (PolyplateM (A.Structured A.Alternative) BaseOpM opsM
,PolyplateM (A.Structured A.Alternative) opsM () m ,PolyplateM (A.Structured A.Alternative) opsM BaseOpM
,Monad m) => ASTStructured A.Alternative opsM m opsQ r ,Monad m) => ASTStructured A.Alternative opsM m opsQ r
instance (PolyplateM (A.Structured A.Choice) () opsM m instance (PolyplateM (A.Structured A.Choice) BaseOpM opsM
,PolyplateM (A.Structured A.Choice) opsM () m ,PolyplateM (A.Structured A.Choice) opsM BaseOpM
,Monad m) => ASTStructured A.Choice opsM m opsQ r ,Monad m) => ASTStructured A.Choice opsM m opsQ r
instance (PolyplateM (A.Structured A.ExpressionList) () opsM m instance (PolyplateM (A.Structured A.ExpressionList) BaseOpM opsM
,PolyplateM (A.Structured A.ExpressionList) opsM () m ,PolyplateM (A.Structured A.ExpressionList) opsM BaseOpM
,Monad m) => ASTStructured A.ExpressionList opsM m opsQ r ,Monad m) => ASTStructured A.ExpressionList opsM m opsQ r
instance (PolyplateM (A.Structured A.Option) () opsM m instance (PolyplateM (A.Structured A.Option) BaseOpM opsM
,PolyplateM (A.Structured A.Option) opsM () m ,PolyplateM (A.Structured A.Option) opsM BaseOpM
,Monad m) => ASTStructured A.Option opsM m opsQ r ,Monad m) => ASTStructured A.Option opsM m opsQ r
instance (PolyplateM (A.Structured A.Process) () opsM m instance (PolyplateM (A.Structured A.Process) BaseOpM opsM
,PolyplateM (A.Structured A.Process) opsM () m ,PolyplateM (A.Structured A.Process) opsM BaseOpM
,Monad m) => ASTStructured A.Process opsM m opsQ r ,Monad m) => ASTStructured A.Process opsM m opsQ r
instance (PolyplateM (A.Structured A.Variant) () opsM m instance (PolyplateM (A.Structured A.Variant) BaseOpM opsM
,PolyplateM (A.Structured A.Variant) opsM () m ,PolyplateM (A.Structured A.Variant) opsM BaseOpM
,Monad m) => ASTStructured A.Variant opsM m opsQ r ,Monad m) => ASTStructured A.Variant opsM m opsQ r
extOpMS :: forall m opT op0T. extOpMS :: forall m opT op0T.
(PolyplateM (A.Structured ()) () op0T m, (PolyplateM (A.Structured ()) BaseOpM op0T,
PolyplateM (A.Structured A.Alternative) () op0T m, PolyplateM (A.Structured A.Alternative) BaseOpM op0T,
PolyplateM (A.Structured A.Choice) () op0T m, PolyplateM (A.Structured A.Choice) BaseOpM op0T,
PolyplateM (A.Structured A.ExpressionList) () op0T m, PolyplateM (A.Structured A.ExpressionList) BaseOpM op0T,
PolyplateM (A.Structured A.Option) () op0T m, PolyplateM (A.Structured A.Option) BaseOpM op0T,
PolyplateM (A.Structured A.Process) () op0T m, PolyplateM (A.Structured A.Process) BaseOpM op0T,
PolyplateM (A.Structured A.Variant) () op0T m, PolyplateM (A.Structured A.Variant) BaseOpM op0T,
PolyplateM (A.Structured ()) op0T () m, PolyplateM (A.Structured ()) op0T BaseOpM,
PolyplateM (A.Structured A.Alternative) op0T () m, PolyplateM (A.Structured A.Alternative) op0T BaseOpM,
PolyplateM (A.Structured A.Choice) op0T () m, PolyplateM (A.Structured A.Choice) op0T BaseOpM,
PolyplateM (A.Structured A.ExpressionList) op0T () m, PolyplateM (A.Structured A.ExpressionList) op0T BaseOpM,
PolyplateM (A.Structured A.Option) op0T () m, PolyplateM (A.Structured A.Option) op0T BaseOpM,
PolyplateM (A.Structured A.Process) op0T () m, PolyplateM (A.Structured A.Process) op0T BaseOpM,
PolyplateM (A.Structured A.Variant) op0T () m) => PolyplateM (A.Structured A.Variant) op0T BaseOpM,
opT -> Monad m) =>
opT m ->
-- Pairing the next two arguments allows us to apply this function infix: -- Pairing the next two arguments allows us to apply this function infix:
(op0T, -- just a type witness (op0T m, -- just a type witness
forall t. ASTStructured t op0T m () () => A.Structured t -> m (A.Structured t)) -> forall t. ASTStructured t op0T m () () => A.Structured t -> m (A.Structured t)) ->
ExtOpMS m opT ExtOpMS opT m
extOpMS ops (_, f) extOpMS ops (_, f)
= ops = ops
`extOpM` (f :: A.Structured A.Variant -> m (A.Structured A.Variant)) `extOpM` (f :: A.Structured A.Variant -> m (A.Structured A.Variant))
@ -132,21 +134,21 @@ extOpMS ops (_, f)
`extOpM` (f :: A.Structured A.Alternative -> m (A.Structured A.Alternative)) `extOpM` (f :: A.Structured A.Alternative -> m (A.Structured A.Alternative))
`extOpM` (f :: A.Structured () -> m (A.Structured ())) `extOpM` (f :: A.Structured () -> m (A.Structured ()))
applyBottomUpMS :: (PolyplateM t (ExtOpMSP BaseOp) () PassM) => applyBottomUpMS :: (PolyplateM t (ExtOpMS BaseOpM) BaseOpM) =>
(forall a. (Data a, PolyplateM (A.Structured a) () (ExtOpMSP BaseOp) PassM) => (forall a. (Data a, PolyplateM (A.Structured a) BaseOpM (ExtOpMS BaseOpM)) =>
(A.Structured a -> PassM (A.Structured a))) (A.Structured a -> PassM (A.Structured a)))
-> t -> PassM t -> t -> PassM t
applyBottomUpMS f = makeRecurseM ops applyBottomUpMS f = makeRecurseM ops
where where
ops = baseOp `extOpMS` (ops, makeBottomUpM ops f) ops = baseOpM `extOpMS` (ops, makeBottomUpM ops f)
type TransformStructured ops type TransformStructured ops
= (PolyplateM (A.Structured t) () ops PassM, Data t) => Transform (A.Structured t) = (PolyplateM (A.Structured t) BaseOpM ops, Data t) => Transform (A.Structured t)
type TransformStructured' ops type TransformStructured' ops
= (PolyplateM (A.Structured t) () ops PassM = (PolyplateM (A.Structured t) BaseOpM ops
,PolyplateM (A.Structured t) ops () PassM , Data t) => Transform (A.Structured t) ,PolyplateM (A.Structured t) ops BaseOpM, Data t) => Transform (A.Structured t)
type TransformStructuredM' m ops type TransformStructuredM' m ops
= (PolyplateM (A.Structured t) () ops m = (PolyplateM (A.Structured t) BaseOpM ops
,PolyplateM (A.Structured t) ops () m , Data t) => A.Structured t -> m (A.Structured t) ,PolyplateM (A.Structured t) ops BaseOpM, Data t) => A.Structured t -> m (A.Structured t)

20
polyplate/Data/Generics/Polyplate.hs
View File

@ -178,8 +178,8 @@ import Data.Generics.Polyplate.Route
-- --
-- Generally you will not use this function or type-class directly, but will instead -- Generally you will not use this function or type-class directly, but will instead
-- use the helper functions lower down in this module. -- use the helper functions lower down in this module.
class Monad m => PolyplateMRoute t o o' m outer where class PolyplateMRoute t o o' where
transformMRoute :: o m outer -> o' m outer -> (t, Route t outer) -> m t transformMRoute :: Monad m => o m outer -> o' m outer -> (t, Route t outer) -> m t
-- | A derivative of PolyplateMRoute without all the route stuff. -- | A derivative of PolyplateMRoute without all the route stuff.
-- --
@ -217,14 +217,14 @@ class Monad m => PolyplateMRoute t o o' m outer where
-- --
-- Generally you will not use this function or type-class directly, but will instead -- Generally you will not use this function or type-class directly, but will instead
-- use the helper functions lower down in this module. -- use the helper functions lower down in this module.
class (Monad m) => PolyplateM t o o' m where class PolyplateM t o o' where
transformM :: o m -> o' m -> t -> m t transformM :: (Monad m) => o m -> o' m -> t -> m t
instance (Monad m instance (
, PolyplateMRoute t o o' m () PolyplateMRoute t o o'
, ConvertOpsToIgnoreRoute ro o , ConvertOpsToIgnoreRoute ro o
, ConvertOpsToIgnoreRoute ro' o') => PolyplateM t ro ro' m where , ConvertOpsToIgnoreRoute ro' o') => PolyplateM t ro ro' where
transformM o o' t = transformMRoute (convertOpsToIgnoreRoute o) transformM o o' t = transformMRoute (convertOpsToIgnoreRoute o)
(convertOpsToIgnoreRoute o') (convertOpsToIgnoreRoute o')
(t, fakeRoute t) (t, fakeRoute t)
@ -238,12 +238,12 @@ instance (Monad m
class Polyplate t o o' where class Polyplate t o o' where
transform :: o -> o' -> t -> t transform :: o -> o' -> t -> t
instance (PolyplateM t mo mo' Identity, ConvertOpsToIdentity o mo, ConvertOpsToIdentity o' mo') => Polyplate t o o' where instance (PolyplateM t mo mo', ConvertOpsToIdentity o mo, ConvertOpsToIdentity o' mo') => Polyplate t o o' where
transform o o' t = runIdentity (transformM (convertOpsToIdentity o) (convertOpsToIdentity o') t) transform o o' t = runIdentity (transformM (convertOpsToIdentity o) (convertOpsToIdentity o') t)
-- | A type representing a monadic modifier function that applies the given ops -- | A type representing a monadic modifier function that applies the given ops
-- (opT) in the given monad (m) directly to the given type (t). -- (opT) in the given monad (m) directly to the given type (t).
type RecurseM m opT = forall t. PolyplateM t opT BaseOpM m => t -> m t type RecurseM m opT = forall t. PolyplateM t opT BaseOpM => t -> m t
-- | Given a set of operations (as described in the 'PolyplateM' type-class), -- | Given a set of operations (as described in the 'PolyplateM' type-class),
-- makes a recursive modifier function. -- makes a recursive modifier function.
@ -252,7 +252,7 @@ makeRecurseM ops = transformM ops baseOpM
-- | A type representing a monadic modifier function that applies the given ops -- | A type representing a monadic modifier function that applies the given ops
-- (opT) in the given monad (m) to the children of the given type (t). -- (opT) in the given monad (m) to the children of the given type (t).
type DescendM m opT = forall t. PolyplateM t BaseOpM opT m => t -> m t type DescendM m opT = forall t. PolyplateM t BaseOpM opT => t -> m t
-- | Given a set of operations (as described in the 'PolyplateM' type-class), -- | Given a set of operations (as described in the 'PolyplateM' type-class),
-- makes a descent modifier function that applies the operation to the type's children. -- makes a descent modifier function that applies the operation to the type's children.

20
polyplate/Data/Generics/Polyplate/GenInstances.hs
View File

@ -305,7 +305,7 @@ instancesFrom genOverlapped genClass boxes w
-- and last arguments swapped. -- and last arguments swapped.
genInst :: [String] -> String -> String -> [String] -> [String] genInst :: [String] -> String -> String -> [String] -> [String]
genInst context ops0 ops1 body genInst context ops0 ops1 body
= ["instance (Monad m" ++ concatMap (", " ++) context ++ ") =>" = ["instance (" ++ concat (intersperse ", " context) ++ ") =>"
," " ++ contextSameType ops0 ops1 ++ " where" ," " ++ contextSameType ops0 ops1 ++ " where"
] ++ map (" " ++) body ] ++ map (" " ++) body
@ -313,17 +313,17 @@ instancesFrom genOverlapped genClass boxes w
-- sets. The class name will be the same as genInst. -- sets. The class name will be the same as genInst.
contextSameType :: String -> String -> String contextSameType :: String -> String -> String
contextSameType ops0 ops1 = case genClass of contextSameType ops0 ops1 = case genClass of
GenOneClass -> "PolyplateMRoute (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m outer" GenOneClass -> "PolyplateMRoute (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1
GenClassPerType -> "PolyplateMRoute" ++ wMunged ++" " ++ ops0 ++ " " ++ ops1 ++ " m outer" GenClassPerType -> "PolyplateMRoute" ++ wMunged ++" " ++ ops0 ++ " " ++ ops1
GenSlowDelegate -> "PolyplateMRoute' m " ++ ops0 ++ " " ++ ops1 ++ " (" ++ wName ++ ") outer" GenSlowDelegate -> "PolyplateMRoute' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ wName ++ ")"
-- Generates the name of an instance for a different type (for processing children). -- Generates the name of an instance for a different type (for processing children).
-- This will be PolyplateM or PolyplateM'. -- This will be PolyplateM or PolyplateM'.
contextNewType :: String -> String -> String -> String contextNewType :: String -> String -> String -> String
contextNewType cName ops0 ops1 = case genClass of contextNewType cName ops0 ops1 = case genClass of
GenOneClass -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m outer" GenOneClass -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1
GenClassPerType -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m outer" GenClassPerType -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1
GenSlowDelegate -> "PolyplateMRoute' m " ++ ops0 ++ " " ++ ops1 ++ " (" ++ cName ++ ") outer" GenSlowDelegate -> "PolyplateMRoute' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ cName ++ ")"
-- The function to define in the body, and also to use for processing the same -- The function to define in the body, and also to use for processing the same
@ -362,12 +362,12 @@ instancesFrom genOverlapped genClass boxes w
"(a :-@ r)" "ops" "(a :-@ r)" "ops"
[funcSameType ++ " (_ :-@ rest) ops vr = " ++ funcSameType ++ " rest ops vr"] [funcSameType ++ " (_ :-@ rest) ops vr = " ++ funcSameType ++ " rest ops vr"]
,if genClass == GenClassPerType ,if genClass == GenClassPerType
then ["class Monad m => PolyplateMRoute" ++ wMunged ++ " o o' m outer where" then ["class PolyplateMRoute" ++ wMunged ++ " o o' where"
," " ++ funcSameType ++ " :: o m outer -> o' m outer -> (" ++ wName ," " ++ funcSameType ++ " :: o m outer -> o' m outer -> (" ++ wName
++ ", Route (" ++ wName ++ ") outer) -> m (" ++ wName ++ ")" ++ ", Route (" ++ wName ++ ") outer) -> m (" ++ wName ++ ")"
,"" ,""
,"instance (Monad m, " ++ contextSameType "o0" "o1" ++ ") =>" ,"instance (" ++ contextSameType "o0" "o1" ++ ") =>"
," PolyplateMRoute (" ++ wName ++ ") o0 o1 m outer where" ," PolyplateMRoute (" ++ wName ++ ") o0 o1 where"
," transformMRoute = " ++ funcSameType ," transformMRoute = " ++ funcSameType
] ]
else [] else []

54
polyplate/Data/Generics/Polyplate/Schemes.hs
View File

@ -37,11 +37,11 @@ makeBottomUp ops f v = f (makeDescend ops v)
-- function to first descend into the value before then applying the modifier function. -- function to first descend into the value before then applying the modifier function.
-- This can be used to perform a bottom-up depth-first traversal of a structure -- This can be used to perform a bottom-up depth-first traversal of a structure
-- (see 'applyBottomUpM'). -- (see 'applyBottomUpM').
makeBottomUpM :: PolyplateM t BaseOpM opT m => opT m -> (t -> m t) -> t -> m t makeBottomUpM :: (PolyplateM t BaseOpM opT, Monad m) => opT m -> (t -> m t) -> t -> m t
makeBottomUpM ops f v = makeDescendM ops v >>= f makeBottomUpM ops f v = makeDescendM ops v >>= f
-- | As makeBottomUpM, but with routes as well. -- | As makeBottomUpM, but with routes as well.
makeBottomUpMRoute :: forall m opT t outer. PolyplateMRoute t BaseOpMRoute opT m outer => makeBottomUpMRoute :: forall m opT t outer. (Monad m, PolyplateMRoute t BaseOpMRoute opT) =>
opT m outer -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t opT m outer -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t
makeBottomUpMRoute ops f (v, r) makeBottomUpMRoute ops f (v, r)
= do v' <- transformMRoute base ops (v, r) = do v' <- transformMRoute base ops (v, r)
@ -61,11 +61,11 @@ makeTopDown ops f v = makeDescend ops (f v)
-- function to first apply the modifier function before then descending into the value. -- function to first apply the modifier function before then descending into the value.
-- This can be used to perform a top-down depth-first traversal of a structure -- This can be used to perform a top-down depth-first traversal of a structure
-- (see 'applyTopDownM'). -- (see 'applyTopDownM').
makeTopDownM :: PolyplateM t BaseOpM opT m => opT m -> (t -> m t) -> t -> m t makeTopDownM :: (PolyplateM t BaseOpM opT, Monad m) => opT m -> (t -> m t) -> t -> m t
makeTopDownM ops f v = f v >>= makeDescendM ops makeTopDownM ops f v = f v >>= makeDescendM ops
-- | As makeTopDownM, but with routes as well. -- | As makeTopDownM, but with routes as well.
makeTopDownMRoute :: PolyplateMRoute t BaseOpMRoute opT m outer => makeTopDownMRoute :: (PolyplateMRoute t BaseOpMRoute opT, Monad m) =>
opT m outer -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t opT m outer -> ((t, Route t outer) -> m t) -> (t, Route t outer) -> m t
makeTopDownMRoute ops f (v, r) makeTopDownMRoute ops f (v, r)
= do v' <- f (v, r) = do v' <- f (v, r)
@ -89,8 +89,8 @@ makeCheckM ops f v
-- the item in the list, False to drop it), finds all items of type \"s\" in some -- the item in the list, False to drop it), finds all items of type \"s\" in some
-- larger item (of type \"t\") that satisfy this function, listed in depth-first -- larger item (of type \"t\") that satisfy this function, listed in depth-first
-- order. -- order.
listifyDepth :: (PolyplateM t (OneOpM s) BaseOpM (State [s]) listifyDepth :: (PolyplateM t (OneOpM s) BaseOpM
,PolyplateM s BaseOpM (OneOpM s) (State [s])) => (s -> Bool) -> t -> [s] ,PolyplateM s BaseOpM (OneOpM s)) => (s -> Bool) -> t -> [s]
-- We use applyBottomUp because we are prepending to the list. If we prepend from -- We use applyBottomUp because we are prepending to the list. If we prepend from
-- the bottom up, that's the same as appending from the top down, which is what -- the bottom up, that's the same as appending from the top down, which is what
-- this function is meant to be doing. -- this function is meant to be doing.
@ -99,8 +99,8 @@ listifyDepth qf = flip execState [] . applyBottomUpM qf'
qf' x = if qf x then modify (x:) >> return x else return x qf' x = if qf x then modify (x:) >> return x else return x
-- | Like listifyDepth, but with routes -- | Like listifyDepth, but with routes
listifyDepthRoute :: (PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute) (State [(s, Route s t)]) t listifyDepthRoute :: (PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute)
,PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s) (State [(s, Route s t)]) t) ,PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s))
=> ((s, Route s t) -> Bool) -> t -> [(s, Route s t)] => ((s, Route s t) -> Bool) -> t -> [(s, Route s t)]
listifyDepthRoute qf = flip execState [] . applyBottomUpMRoute qf' listifyDepthRoute qf = flip execState [] . applyBottomUpMRoute qf'
where where
@ -115,15 +115,15 @@ listifyDepthRoute qf = flip execState [] . applyBottomUpMRoute qf'
-- --
-- This can be used, for example, to perform checks on items in an error monad, -- This can be used, for example, to perform checks on items in an error monad,
-- or to accumulate information in a state monad. -- or to accumulate information in a state monad.
checkDepthM :: (Monad m, PolyplateM t (OneOpM s) BaseOpM m checkDepthM :: (Monad m, PolyplateM t (OneOpM s) BaseOpM
, PolyplateM s BaseOpM (OneOpM s) m) => (s -> m ()) -> t -> m () , PolyplateM s BaseOpM (OneOpM s)) => (s -> m ()) -> t -> m ()
checkDepthM f x = applyBottomUpM (\x -> f x >> return x) x >> return () checkDepthM f x = applyBottomUpM (\x -> f x >> return x) x >> return ()
-- | As 'checkDepthM', but takes two functions (one operating on type \"r\", the -- | As 'checkDepthM', but takes two functions (one operating on type \"r\", the
-- other on type \"s\"). -- other on type \"s\").
checkDepthM2 :: (Monad m, PolyplateM t (TwoOpM r s) (BaseOpM) m checkDepthM2 :: (Monad m, PolyplateM t (TwoOpM r s) (BaseOpM)
, PolyplateM r (BaseOpM) (TwoOpM r s) m , PolyplateM r (BaseOpM) (TwoOpM r s)
, PolyplateM s (BaseOpM) (TwoOpM r s) m , PolyplateM s (BaseOpM) (TwoOpM r s)
) => ) =>
(r -> m ()) -> (s -> m ()) -> t -> m () (r -> m ()) -> (s -> m ()) -> t -> m ()
checkDepthM2 f g x = applyBottomUpM2 (\x -> f x >> return x) checkDepthM2 f g x = applyBottomUpM2 (\x -> f x >> return x)
@ -137,16 +137,17 @@ checkDepthM2 f g x = applyBottomUpM2 (\x -> f x >> return x)
-- traversal in order of a constructor's children (assuming you are using one of -- traversal in order of a constructor's children (assuming you are using one of
-- the generated instances, not your own), descending first and applying the function -- the generated instances, not your own), descending first and applying the function
-- afterwards on the way back up. -- afterwards on the way back up.
applyBottomUpM :: (PolyplateM t (OneOpM s) BaseOpM m, applyBottomUpM :: (PolyplateM t (OneOpM s) BaseOpM,
PolyplateM s BaseOpM (OneOpM s) m) => PolyplateM s BaseOpM (OneOpM s), Monad m) =>
(s -> m s) -> t -> m t (s -> m s) -> t -> m t
applyBottomUpM f = makeRecurseM ops applyBottomUpM f = makeRecurseM ops
where where
ops = baseOpM `extOpM` makeBottomUpM ops f ops = baseOpM `extOpM` makeBottomUpM ops f
applyBottomUpMRoute :: forall m s t. applyBottomUpMRoute :: forall m s t.
(PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute) m t, (PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute),
PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s) m t) => PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s),
Monad m) =>
((s, Route s t) -> m s) -> t -> m t ((s, Route s t) -> m s) -> t -> m t
applyBottomUpMRoute f x = transformMRoute ops base (x, identityRoute) applyBottomUpMRoute f x = transformMRoute ops base (x, identityRoute)
where where
@ -158,9 +159,10 @@ applyBottomUpMRoute f x = transformMRoute ops base (x, identityRoute)
-- | As 'applyBottomUpM', but applies two functions. These should not be modifying -- | As 'applyBottomUpM', but applies two functions. These should not be modifying
-- the same type. -- the same type.
applyBottomUpM2 :: (PolyplateM t (TwoOpM sA sB) (BaseOpM) m, applyBottomUpM2 :: (PolyplateM t (TwoOpM sA sB) (BaseOpM),
PolyplateM sA (BaseOpM) (TwoOpM sA sB) m, PolyplateM sA (BaseOpM) (TwoOpM sA sB),
PolyplateM sB (BaseOpM) (TwoOpM sA sB) m PolyplateM sB (BaseOpM) (TwoOpM sA sB),
Monad m
) => ) =>
(sA -> m sA) -> (sB -> m sB) -> t -> m t (sA -> m sA) -> (sB -> m sB) -> t -> m t
applyBottomUpM2 fA fB = makeRecurseM ops applyBottomUpM2 fA fB = makeRecurseM ops
@ -190,8 +192,9 @@ applyBottomUp2 fA fB = makeRecurse ops
-- traversal in order of a constructor's children (assuming you are using one of -- traversal in order of a constructor's children (assuming you are using one of
-- the generated instances, not your own), applying the function first and then -- the generated instances, not your own), applying the function first and then
-- descending. -- descending.
applyTopDownM :: (PolyplateM t (s :-* BaseOpM) BaseOpM m, applyTopDownM :: (PolyplateM t (s :-* BaseOpM) BaseOpM,
PolyplateM s BaseOpM (s :-* BaseOpM) m) => PolyplateM s BaseOpM (s :-* BaseOpM),
Monad m) =>
(s -> m s) -> t -> m t (s -> m s) -> t -> m t
applyTopDownM f = makeRecurseM ops applyTopDownM f = makeRecurseM ops
where where
@ -199,9 +202,10 @@ applyTopDownM f = makeRecurseM ops
-- | As applyTopDownM, but applies two functions. These should not be modifying -- | As applyTopDownM, but applies two functions. These should not be modifying
-- the same type. -- the same type.
applyTopDownM2 :: (PolyplateM t (sA :-* sB :-* BaseOpM) BaseOpM m, applyTopDownM2 :: (PolyplateM t (sA :-* sB :-* BaseOpM) BaseOpM,
PolyplateM sA BaseOpM (sA :-* sB :-* BaseOpM) m, PolyplateM sA BaseOpM (sA :-* sB :-* BaseOpM),
PolyplateM sB BaseOpM (sA :-* sB :-* BaseOpM) m PolyplateM sB BaseOpM (sA :-* sB :-* BaseOpM),
Monad m
) => ) =>
(sA -> m sA) -> (sB -> m sB) -> t -> m t (sA -> m sA) -> (sB -> m sB) -> t -> m t
applyTopDownM2 fA fB = makeRecurseM ops applyTopDownM2 fA fB = makeRecurseM ops

16
transformations/ImplicitMobility.hs
View File

@ -203,15 +203,15 @@ implicitMobility
mobiliseArrays :: PassASTOnStruct mobiliseArrays :: PassASTOnStruct
mobiliseArrays = pass "Make all arrays mobile" [] [] recurse mobiliseArrays = pass "Make all arrays mobile" [] [] recurse
where where
ops :: ExtOpMSP BaseOp ops :: ExtOpMSP BaseOpM
ops = baseOp `extOpMS` (ops, doStructured) ops = baseOpM `extOpMS` (ops, doStructured)
recurse :: RecurseM PassM (ExtOpMSP BaseOp) recurse :: RecurseM PassM (ExtOpMS BaseOpM)
recurse = makeRecurseM ops recurse = makeRecurseM ops
descend :: DescendM PassM (ExtOpMSP BaseOp) descend :: DescendM PassM (ExtOpMS BaseOpM)
descend = makeDescendM ops descend = makeDescendM ops
doStructured :: TransformStructured' (ExtOpMSP BaseOp) doStructured :: TransformStructured' (ExtOpMS BaseOpM)
doStructured s@(A.Spec m (A.Specification m' n (A.Declaration m'' t@(A.Array ds doStructured s@(A.Spec m (A.Specification m' n (A.Declaration m'' t@(A.Array ds
innerT))) scope) innerT))) scope)
= case innerT of = case innerT of
@ -309,11 +309,11 @@ instance Dereferenceable A.Actual where
inferDeref :: PassOn2 A.Process A.Variable inferDeref :: PassOn2 A.Process A.Variable
inferDeref = pass "Infer mobile dereferences" [] [] recurse inferDeref = pass "Infer mobile dereferences" [] [] recurse
where where
ops = baseOp `extOpM` doProcess `extOpM` doVariable ops = doProcess :-* doVariable :-* baseOpM
recurse :: RecurseM PassM (TwoOpM PassM A.Process A.Variable) recurse :: RecurseM PassM (TwoOpM A.Process A.Variable)
recurse = makeRecurseM ops recurse = makeRecurseM ops
descend :: DescendM PassM (TwoOpM PassM A.Process A.Variable) descend :: DescendM PassM (TwoOpM A.Process A.Variable)
descend = makeDescendM ops descend = makeDescendM ops
unify :: (Dereferenceable a, ASTTypeable a, ShowOccam a, ShowRain a) => Meta unify :: (Dereferenceable a, ASTTypeable a, ShowOccam a, ShowRain a) => Meta

28
transformations/SimplifyAbbrevs.hs
View File

@ -49,14 +49,14 @@ simplifyAbbrevs =
] ]
-- | Rewrite 'InitialAbbrev' into a variable and an assignment. -- | Rewrite 'InitialAbbrev' into a variable and an assignment.
removeInitial :: PassOnOps (ExtOpMSP BaseOp) removeInitial :: PassOnOps (ExtOpMS BaseOpM)
removeInitial removeInitial
= pass "Remove INITIAL abbreviations" = pass "Remove INITIAL abbreviations"
[] []
[Prop.initialRemoved] [Prop.initialRemoved]
(applyBottomUpMS doStructured) (applyBottomUpMS doStructured)
where where
doStructured :: TransformStructured (ExtOpMSP BaseOp) doStructured :: TransformStructured (ExtOpMS BaseOpM)
doStructured (A.Spec m spec s) = doSpec m spec s doStructured (A.Spec m spec s) = doSpec m spec s
doStructured s = return s doStructured s = return s
@ -191,20 +191,20 @@ updateAbbrevsInState
doAbbrevMode s = s doAbbrevMode s = s
type AbbrevCheckM = StateT [Map.Map Var Bool] PassM type AbbrevCheckM = StateT [Map.Map Var Bool] PassM
type ExtAbbM a b = ExtOpM AbbrevCheckM a b
type AbbrevCheckOps
= ExtOpMS AbbrevCheckM BaseOp
`ExtAbbM` A.Variable
`ExtAbbM` A.Process
`ExtAbbM` A.InputItem
abbrevCheckPass :: (PolyplateM t AbbrevCheckOps () AbbrevCheckM, PolyplateM t () AbbrevCheckOps AbbrevCheckM) => Pass t type AbbrevCheckOps
= ExtOpMS BaseOpM
`ExtOpMP` A.Variable
`ExtOpMP` A.Process
`ExtOpMP` A.InputItem
abbrevCheckPass :: (PolyplateM t AbbrevCheckOps BaseOpM, PolyplateM t BaseOpM AbbrevCheckOps) => Pass t
abbrevCheckPass abbrevCheckPass
= pass "Abbreviation checking" [] [] = pass "Abbreviation checking" [] []
({-passOnlyOnAST "abbrevCheck" $ -} flip evalStateT [Map.empty] . recurse) ({-passOnlyOnAST "abbrevCheck" $ -} flip evalStateT [Map.empty] . recurse)
where where
ops :: AbbrevCheckOps ops :: AbbrevCheckOps AbbrevCheckM
ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doVariable ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doVariable
`extOpM` doProcess `extOpM` doInputItem `extOpM` doProcess `extOpM` doInputItem
descend :: DescendM AbbrevCheckM AbbrevCheckOps descend :: DescendM AbbrevCheckM AbbrevCheckOps
@ -212,7 +212,7 @@ abbrevCheckPass
recurse :: RecurseM AbbrevCheckM AbbrevCheckOps recurse :: RecurseM AbbrevCheckM AbbrevCheckOps
recurse = makeRecurseM ops recurse = makeRecurseM ops
pushRecurse :: (PolyplateM a AbbrevCheckOps () AbbrevCheckM) => a -> AbbrevCheckM a pushRecurse :: (PolyplateM a AbbrevCheckOps BaseOpM) => a -> AbbrevCheckM a
pushRecurse x = modify (Map.empty:) >> recurse x pushRecurse x = modify (Map.empty:) >> recurse x
pop :: StateT [Map.Map Var Bool] PassM () pop :: StateT [Map.Map Var Bool] PassM ()
pop = modify $ \st -> case st of pop = modify $ \st -> case st of
@ -232,8 +232,8 @@ abbrevCheckPass
-- on an abbreviation if either the RHS *or* the LHS is exempt by a PERMITALIASEs -- on an abbreviation if either the RHS *or* the LHS is exempt by a PERMITALIASEs
-- pragma -- pragma
doStructured :: (PolyplateM (A.Structured t) () AbbrevCheckOps AbbrevCheckM doStructured :: (PolyplateM (A.Structured t) BaseOpM AbbrevCheckOps
,PolyplateM (A.Structured t) AbbrevCheckOps () AbbrevCheckM, Data t) => ,PolyplateM (A.Structured t) AbbrevCheckOps BaseOpM, Data t) =>
A.Structured t -> AbbrevCheckM (A.Structured t) A.Structured t -> AbbrevCheckM (A.Structured t)
doStructured s@(A.Spec _ (A.Specification _ n (A.Is _ A.Abbrev _ (A.ActualVariable v))) scope) doStructured s@(A.Spec _ (A.Specification _ n (A.Is _ A.Abbrev _ (A.ActualVariable v))) scope)
= do nonce <- nameIsNonce n = do nonce <- nameIsNonce n

6
transformations/SimplifyAbbrevsTest.hs
View File

@ -94,8 +94,8 @@ testRemoveInitial = TestLabel "testRemoveInitial" $ TestList
inner) inner)
] ]
where where
ok :: (PolyplateM a (ExtOpMSP BaseOp) () PassM ok :: (PolyplateM a (ExtOpMS BaseOpM) BaseOpM
,PolyplateM a () (ExtOpMSP BaseOp) PassM ,PolyplateM a BaseOpM (ExtOpMS BaseOpM)
,Data a, Data b) => Int -> a -> b -> Test ,Data a, Data b) => Int -> a -> b -> Test
ok n inp exp = TestCase $ testPass ("testRemoveInitial" ++ show n) ok n inp exp = TestCase $ testPass ("testRemoveInitial" ++ show n)
exp removeInitial inp setupState exp removeInitial inp setupState
@ -152,7 +152,7 @@ testRemoveResult = TestLabel "testRemoveResult" $ TestList
(A.Formal A.Abbrev A.Int foo) (A.Formal A.Abbrev A.Int foo)
] ]
where where
ok :: (Polyplate a (OneOp A.AbbrevMode) () ok :: (Polyplate a (OneOp A.AbbrevMode) BaseOp
,Data a, Data b) => Int -> a -> b -> Test ,Data a, Data b) => Int -> a -> b -> Test
ok n inp exp = TestCase $ testPass ("testRemoveResult" ++ show n) ok n inp exp = TestCase $ testPass ("testRemoveResult" ++ show n)
exp removeResult inp setupState exp removeResult inp setupState

8
transformations/SimplifyExprs.hs
View File

@ -215,7 +215,7 @@ pullRepCounts = pass "Pull up replicator counts for SEQs, PARs and ALTs"
return $ A.Seq m $ spec $ A.Only m $ A.Par m p body' return $ A.Seq m $ spec $ A.Only m $ A.Par m p body'
pullRepCountProc p = return p pullRepCountProc p = return p
transformConstr :: PassOnOps (ExtOpMSP BaseOp) transformConstr :: PassOnOps (ExtOpMS BaseOpM)
transformConstr = pass "Transform array constructors into initialisation code" transformConstr = pass "Transform array constructors into initialisation code"
(Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.subscriptsPulledUp]) (Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.subscriptsPulledUp])
[Prop.arrayConstructorsRemoved] [Prop.arrayConstructorsRemoved]
@ -323,7 +323,7 @@ transformConstr = pass "Transform array constructors into initialisation code"
doStructured s = return s doStructured s = return s
type PullUpOps = ExtOpMSP BaseOp type PullUpOps = ExtOpMS BaseOpM
`ExtOpMP` A.Process `ExtOpMP` A.Process
`ExtOpMP` A.Structured A.Expression `ExtOpMP` A.Structured A.Expression
`ExtOpMP` A.Specification `ExtOpMP` A.Specification
@ -340,8 +340,8 @@ pullUp pullUpArraysInsideRecords = pass "Pull up definitions"
[Prop.functionCallsRemoved, Prop.subscriptsPulledUp] [Prop.functionCallsRemoved, Prop.subscriptsPulledUp]
recurse recurse
where where
ops :: PullUpOps ops :: PullUpOps PassM
ops = baseOp ops = baseOpM
`extOpMS` (ops, doStructured) `extOpMS` (ops, doStructured)
`extOpM` doProcess `extOpM` doProcess
`extOpM` doRepArray `extOpM` doRepArray

12
transformations/SimplifyProcs.hs
View File

@ -45,15 +45,15 @@ simplifyProcs =
] ]
type ForkM = StateT [A.Name] PassM type ForkM = StateT [A.Name] PassM
type ForkOps = ExtOpM ForkM (ExtOpMS ForkM BaseOp) A.Process type ForkOps = A.Process :-* (ExtOpMS BaseOpM)
-- | Add an extra barrier parameter to every PROC for FORKING -- | Add an extra barrier parameter to every PROC for FORKING
addForkNames :: PassOnOpsM ForkM ForkOps addForkNames :: PassOnOpsM ForkOps
addForkNames = occamOnlyPass "Add FORK labels" [] [] addForkNames = occamOnlyPass "Add FORK labels" [] []
(flip evalStateT [] . recurse) (flip evalStateT [] . recurse)
where where
ops :: ForkOps ops :: ForkOps ForkM
ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doProcess ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doProcess
recurse :: RecurseM ForkM ForkOps recurse :: RecurseM ForkM ForkOps
recurse = makeRecurseM ops recurse = makeRecurseM ops
@ -153,13 +153,13 @@ removeParAssign = pass "Remove parallel assignment"
doProcess p = return p doProcess p = return p
-- | Turn assignment of arrays and records into multiple assignments. -- | Turn assignment of arrays and records into multiple assignments.
flattenAssign :: PassOnOps (ExtOpMSP BaseOp `ExtOpMP` A.Process) flattenAssign :: PassOnOps (A.Process :-* ExtOpMS BaseOpM)
flattenAssign = pass "Flatten assignment" flattenAssign = pass "Flatten assignment"
(Prop.agg_typesDone ++ [Prop.assignParRemoved]) (Prop.agg_typesDone ++ [Prop.assignParRemoved])
[Prop.assignFlattened] [Prop.assignFlattened]
(makeRecurseM ops) (makeRecurseM ops)
where where
ops = baseOp `extOpMS` (ops, makeBottomUpM ops doStructured) ops = baseOpM `extOpMS` (ops, makeBottomUpM ops doStructured)
`extOpM` makeBottomUpM ops doProcess `extOpM` makeBottomUpM ops doProcess
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process

4
transformations/SimplifyTypesTest.hs
View File

@ -51,8 +51,8 @@ testResolveNamedTypes = TestLabel "testResolveNamedTypes" $ TestList
(array10 A.Int) (array10 A.Int)
] ]
where where
ok :: (PolyplateM a (OneOpM PassM A.Type) () PassM ok :: (PolyplateM a (OneOpM A.Type) BaseOpM
,PolyplateM a () (OneOpM PassM A.Type) PassM ,PolyplateM a BaseOpM (OneOpM A.Type)
,Data a, Data b) => Int -> a -> b -> Test ,Data a, Data b) => Int -> a -> b -> Test
ok n inp exp = TestCase $ testPass ("testResolveNamedTypes" ++ show n) ok n inp exp = TestCase $ testPass ("testResolveNamedTypes" ++ show n)
exp resolveNamedTypes inp setupState exp resolveNamedTypes inp setupState

46
transformations/Unnest.hs
View File

@ -48,22 +48,22 @@ type NameMap = Map.Map String A.Name
type FreeNameM = State (Map.Map String A.Name) type FreeNameM = State (Map.Map String A.Name)
type FreeNameOps = ExtOpM FreeNameM (ExtOpMS FreeNameM (ExtOpM FreeNameM BaseOp A.Name)) A.SpecType type FreeNameOps = A.SpecType :-* (ExtOpMS (A.Name :-* BaseOpM))
-- | Get the set of free names within a block of code. -- | Get the set of free names within a block of code.
freeNamesIn :: PolyplateM t FreeNameOps () FreeNameM => t -> NameMap freeNamesIn :: PolyplateM t FreeNameOps BaseOpM => t -> NameMap
freeNamesIn = flip execState Map.empty . recurse freeNamesIn = flip execState Map.empty . recurse
where where
flattenTree :: Tree (Maybe NameMap) -> NameMap flattenTree :: Tree (Maybe NameMap) -> NameMap
flattenTree = foldl Map.union Map.empty . catMaybes . flatten flattenTree = foldl Map.union Map.empty . catMaybes . flatten
ops :: FreeNameOps ops :: FreeNameOps FreeNameM
ops = baseOp `extOpM` doName `extOpMS` (ops, doStructured) `extOpM` doSpecType ops = baseOpM `extOpM` doName `extOpMS` (ops, doStructured) `extOpM` doSpecType
recurse :: PolyplateM t FreeNameOps () FreeNameM => t -> FreeNameM t recurse :: PolyplateM t FreeNameOps BaseOpM => t -> FreeNameM t
recurse = transformM ops () recurse = transformM ops baseOpM
descend :: PolyplateM t () FreeNameOps FreeNameM => t -> FreeNameM t descend :: PolyplateM t BaseOpM FreeNameOps => t -> FreeNameM t
descend = transformM () ops descend = transformM baseOpM ops
ignore :: t -> NameMap ignore :: t -> NameMap
ignore s = Map.empty ignore s = Map.empty
@ -71,15 +71,15 @@ freeNamesIn = flip execState Map.empty . recurse
doName :: A.Name -> FreeNameM A.Name doName :: A.Name -> FreeNameM A.Name
doName n = modify (Map.insert (A.nameName n) n) >> return n doName n = modify (Map.insert (A.nameName n) n) >> return n
doStructured :: (Data a, PolyplateM (A.Structured a) () FreeNameOps FreeNameM doStructured :: (Data a, PolyplateM (A.Structured a) BaseOpM FreeNameOps
, PolyplateM (A.Structured a) FreeNameOps () FreeNameM , PolyplateM (A.Structured a) FreeNameOps BaseOpM
) )
=> A.Structured a -> FreeNameM (A.Structured a) => A.Structured a -> FreeNameM (A.Structured a)
doStructured x@(A.Spec _ spec s) = doSpec spec s >> return x doStructured x@(A.Spec _ spec s) = doSpec spec s >> return x
doStructured s = descend s doStructured s = descend s
doSpec :: (PolyplateM t () FreeNameOps FreeNameM doSpec :: (PolyplateM t BaseOpM FreeNameOps
,PolyplateM t FreeNameOps () FreeNameM) => A.Specification -> t -> FreeNameM () ,PolyplateM t FreeNameOps BaseOpM) => A.Specification -> t -> FreeNameM ()
doSpec (A.Specification _ n st) child doSpec (A.Specification _ n st) child
= modify (Map.union $ Map.union fns $ Map.delete (A.nameName n) $ freeNamesIn child) = modify (Map.union $ Map.union fns $ Map.delete (A.nameName n) $ freeNamesIn child)
where where
@ -98,15 +98,15 @@ freeNamesIn = flip execState Map.empty . recurse
-- have expressions as dimensions, and those expressions can contain free names -- have expressions as dimensions, and those expressions can contain free names
-- which are being replaced. This is fine, but when that happens we need to update -- which are being replaced. This is fine, but when that happens we need to update
-- CompState so that the type has the replaced name, not the old name. -- CompState so that the type has the replaced name, not the old name.
replaceNames :: PolyplateM t (TwoOpM PassM A.Name A.Specification) () PassM => [(A.Name, A.Name)] -> t -> PassM t replaceNames :: PolyplateM t (TwoOpM A.Name A.Specification) BaseOpM => [(A.Name, A.Name)] -> t -> PassM t
replaceNames map = recurse replaceNames map = recurse
where where
smap = Map.fromList [(A.nameName f, t) | (f, t) <- map] smap = Map.fromList [(A.nameName f, t) | (f, t) <- map]
ops :: TwoOpM PassM A.Name A.Specification ops :: TwoOpM A.Name A.Specification PassM
ops = baseOp `extOpM` doName `extOpM` doSpecification ops = doName :-* doSpecification :-* baseOpM
recurse :: RecurseM PassM (TwoOpM PassM A.Name A.Specification) recurse :: RecurseM PassM (TwoOpM A.Name A.Specification)
recurse = makeRecurseM ops recurse = makeRecurseM ops
doName :: Transform A.Name doName :: Transform A.Name
@ -124,7 +124,7 @@ replaceNames map = recurse
return $ A.Specification m n' sp' return $ A.Specification m n' sp'
-- | Turn free names in PROCs into arguments. -- | Turn free names in PROCs into arguments.
removeFreeNames :: PassOnM2 (StateT (Map.Map String [A.Actual]) PassM) A.Specification A.Process removeFreeNames :: PassOnM2 A.Specification A.Process
removeFreeNames = pass "Convert free names to arguments" removeFreeNames = pass "Convert free names to arguments"
[Prop.mainTagged, Prop.parsWrapped, Prop.functionCallsRemoved] [Prop.mainTagged, Prop.parsWrapped, Prop.functionCallsRemoved]
[Prop.freeNamesToArgs] [Prop.freeNamesToArgs]
@ -213,7 +213,7 @@ removeFreeNames = pass "Convert free names to arguments"
doProcess p = return p doProcess p = return p
-- | Pull nested declarations to the top level. -- | Pull nested declarations to the top level.
removeNesting :: PassASTOnOps (ExtOpMSP BaseOp) removeNesting :: PassASTOnOps (ExtOpMS BaseOpM)
removeNesting = pass "Pull nested definitions to top level" removeNesting = pass "Pull nested definitions to top level"
[Prop.freeNamesToArgs] [Prop.freeNamesToArgs]
[Prop.nestedPulled] [Prop.nestedPulled]
@ -223,16 +223,16 @@ removeNesting = pass "Pull nested definitions to top level"
popPullContext popPullContext
return s') return s')
where where
ops :: ExtOpMSP BaseOp ops :: ExtOpMSP BaseOpM
ops = baseOp `extOpMS` (ops, doStructured) ops = baseOpM `extOpMS` (ops, doStructured)
recurse :: RecurseM PassM (ExtOpMSP BaseOp) recurse :: RecurseM PassM (ExtOpMS BaseOpM)
recurse = makeRecurseM ops recurse = makeRecurseM ops
descend :: DescendM PassM (ExtOpMSP BaseOp) descend :: DescendM PassM (ExtOpMS BaseOpM)
descend = makeDescendM ops descend = makeDescendM ops
doStructured :: TransformStructured (ExtOpMSP BaseOp) doStructured :: TransformStructured (ExtOpMS BaseOpM)
doStructured s@(A.Spec m spec subS) doStructured s@(A.Spec m spec subS)
= do spec'@(A.Specification _ n st) <- recurse spec = do spec'@(A.Specification _ n st) <- recurse spec
isConst <- isConstantName n isConst <- isConstantName n