Reworked Polyplate to have a simpler way of expressing opsets, and also simplified PolyplateM and PolyplateMRoute
This commit is contained in:
Neil Brown
parent
efa5c57fd0
commit
44eabe4baa
|
|
@ -99,7 +99,7 @@ removeUnneededDirections
|
|||
_ -> diePC m $ formatCode "Direction applied to non-channel type: %" t
|
||||
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
|
||||
-- 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 = cOnlyPass "Pull up mobile initialisers" [] [] recurse
|
||||
where
|
||||
ops :: AllocMobileOps
|
||||
ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doProcess
|
||||
ops :: AllocMobileOps PassM
|
||||
ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doProcess
|
||||
|
||||
recurse :: RecurseM PassM AllocMobileOps
|
||||
recurse = makeRecurseM ops
|
||||
|
|
@ -318,7 +318,7 @@ findVarSizes skip (A.VariableSizes m v)
|
|||
mn <- getSizes m (A.VariableSizes m v) 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.
|
||||
-- For each record type it declares a _sizes array too.
|
||||
|
|
@ -333,8 +333,8 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays"
|
|||
return t'
|
||||
))
|
||||
where
|
||||
ops :: DeclSizeOps
|
||||
ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doProcess
|
||||
ops :: DeclSizeOps SizesM
|
||||
ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doProcess
|
||||
|
||||
recurse :: RecurseM SizesM DeclSizeOps
|
||||
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
|
||||
t = A.Array [A.Dimension $ makeConstant m (length es)] A.Int
|
||||
|
||||
doStructured :: (Data a, PolyplateM (A.Structured a) DeclSizeOps () SizesM
|
||||
, PolyplateM (A.Structured a) () DeclSizeOps SizesM)
|
||||
doStructured :: (Data a, PolyplateM (A.Structured a) DeclSizeOps BaseOpM
|
||||
, PolyplateM (A.Structured a) BaseOpM DeclSizeOps)
|
||||
=> (A.Structured a) -> SizesM (A.Structured a)
|
||||
doStructured str@(A.Spec m sp@(A.Specification m' n spec) s)
|
||||
= do t <- typeOfSpec spec
|
||||
|
|
|
|||
|
|
@ -515,9 +515,7 @@ checkInitVar = forAnyFlowNode
|
|||
warnP m WarnUninitialisedVariable $ "Variable(s) read from are not written to before-hand: " ++ vars
|
||||
|
||||
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
|
||||
(A.Structured t))
|
||||
() (State [(A.Process, Route A.Process (A.Structured t))]) (A.Structured t))
|
||||
PolyplateMRoute (A.Structured t) (OneOpMRoute A.Process) BaseOpMRoute)
|
||||
=> (A.Process -> Bool) -> FlowGraph' m a t -> A.Structured t -> [(A.Process, a)]
|
||||
findAllProcess f g t = Map.elems $ Map.intersectionWith (,) astMap nodeMap
|
||||
where
|
||||
|
|
@ -533,9 +531,7 @@ findAllProcess f g t = Map.elems $ Map.intersectionWith (,) astMap nodeMap
|
|||
_ -> Nothing
|
||||
|
||||
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
|
||||
(A.Structured t))
|
||||
() (State [(A.Process, Route A.Process (A.Structured t))]) (A.Structured t)
|
||||
PolyplateMRoute (A.Structured t) (OneOpMRoute A.Process) BaseOpMRoute
|
||||
) => FlowGraph' m (BK, UsageLabel) t -> A.Structured t -> m ()
|
||||
checkParAssignUsage g = mapM_ checkParAssign . findAllProcess isParAssign g
|
||||
where
|
||||
|
|
@ -556,9 +552,8 @@ checkParAssignUsage g = mapM_ checkParAssign . findAllProcess isParAssign g
|
|||
$ processVarW v Nothing] | v <- vs]
|
||||
|
||||
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
|
||||
(A.Structured t))
|
||||
() (State [(A.Process, Route A.Process (A.Structured t))]) (A.Structured t)
|
||||
PolyplateMRoute (A.Structured t) (OneOpMRoute A.Process)
|
||||
BaseOpMRoute
|
||||
) =>
|
||||
FlowGraph' m (BK, UsageLabel) t -> A.Structured t -> m ()
|
||||
checkProcCallArgsUsage g = mapM_ checkArgs . findAllProcess isProcCall g
|
||||
|
|
|
|||
|
|
@ -260,15 +260,15 @@ forAnyParItems = undefined
|
|||
|
||||
-- | This function currently only supports one type
|
||||
forAnyASTTopDown :: forall a.
|
||||
(PolyplateMRoute A.AST ((a, Route a A.AST) -> RestartT CheckOptM a, ()) () (RestartT CheckOptM) A.AST
|
||||
,PolyplateMRoute a () ((a, Route a A.AST) -> RestartT CheckOptM a, ()) (RestartT CheckOptM) A.AST
|
||||
(PolyplateMRoute A.AST (a :-@ BaseOpMRoute) BaseOpMRoute
|
||||
,PolyplateMRoute a BaseOpMRoute (a :-@ BaseOpMRoute)
|
||||
) =>
|
||||
(a -> CheckOptASTM a ()) -> CheckOptM ()
|
||||
forAnyASTTopDown origF = CheckOptM $ do
|
||||
tr <- get >>* ast
|
||||
doTree ops transformMRoute tr
|
||||
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
|
||||
a) ())) -> CheckOptM ()
|
||||
|
|
@ -277,7 +277,7 @@ forAnyASTStructTopDown origF = CheckOptM $ do
|
|||
doTree ops transformMRoute tr
|
||||
where
|
||||
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.Process -> CheckOptASTM (A.Structured A.Process) ()))
|
||||
`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 () -> 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 =
|
||||
BaseOp
|
||||
`ExtAcc` AccumOp b A.Variant
|
||||
`ExtAcc` AccumOp b A.Process
|
||||
`ExtAcc` AccumOp b A.Option
|
||||
`ExtAcc` AccumOp b A.ExpressionList
|
||||
`ExtAcc` AccumOp b A.Choice
|
||||
`ExtAcc` AccumOp b A.Alternative
|
||||
`ExtAcc` AccumOp b ()
|
||||
`ExtAcc` ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b)
|
||||
BaseOpMRoute
|
||||
`ExtAcc` A.Structured A.Variant
|
||||
`ExtAcc` A.Structured A.Process
|
||||
`ExtAcc` A.Structured A.Option
|
||||
`ExtAcc` A.Structured A.ExpressionList
|
||||
`ExtAcc` A.Structured A.Choice
|
||||
`ExtAcc` A.Structured A.Alternative
|
||||
`ExtAcc` A.Structured ()
|
||||
`ExtAcc` b
|
||||
|
||||
type SingleOps b
|
||||
= ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b, ())
|
||||
= b :-@ BaseOpMRoute
|
||||
|
||||
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.
|
||||
forAnyASTStructBottomUpAccum :: forall b. (Data b,
|
||||
-- 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
|
||||
-- ops:
|
||||
PolyplateMRoute (A.Structured A.Variant) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured A.Process) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured A.Option) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured A.ExpressionList) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured A.Choice) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured A.Alternative) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured ()) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute b () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured A.Variant) BaseOpMRoute (AccumOps b),
|
||||
PolyplateMRoute (A.Structured A.Process) BaseOpMRoute (AccumOps b),
|
||||
PolyplateMRoute (A.Structured A.Option) BaseOpMRoute (AccumOps b),
|
||||
PolyplateMRoute (A.Structured A.ExpressionList) BaseOpMRoute (AccumOps b),
|
||||
PolyplateMRoute (A.Structured A.Choice) BaseOpMRoute (AccumOps b),
|
||||
PolyplateMRoute (A.Structured A.Alternative) BaseOpMRoute (AccumOps b),
|
||||
PolyplateMRoute (A.Structured ()) BaseOpMRoute (AccumOps b),
|
||||
PolyplateMRoute b BaseOpMRoute (AccumOps b),
|
||||
|
||||
-- Allow us to descend into each Structured item with just our ops for
|
||||
-- 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.Process) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured A.Option) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured A.ExpressionList) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured A.Choice) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured A.Alternative) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured ()) (SingleOps b) () (StateT (AccumMap b) (RestartT CheckOptM)) A.AST,
|
||||
PolyplateMRoute (A.Structured A.Variant) (SingleOps b) BaseOpMRoute,
|
||||
PolyplateMRoute (A.Structured A.Process) (SingleOps b) BaseOpMRoute,
|
||||
PolyplateMRoute (A.Structured A.Option) (SingleOps b) BaseOpMRoute,
|
||||
PolyplateMRoute (A.Structured A.ExpressionList) (SingleOps b) BaseOpMRoute,
|
||||
PolyplateMRoute (A.Structured A.Choice) (SingleOps b) BaseOpMRoute,
|
||||
PolyplateMRoute (A.Structured A.Alternative) (SingleOps b) BaseOpMRoute,
|
||||
PolyplateMRoute (A.Structured ()) (SingleOps b) BaseOpMRoute,
|
||||
-- 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 ()
|
||||
|
|
@ -347,12 +345,12 @@ forAnyASTStructBottomUpAccum origF = CheckOptM $ do
|
|||
tr <- get >>* ast
|
||||
doTree ops (\x y z -> flip evalStateT (Map.empty :: AccumMap b) $ transformMRoute x y z) tr
|
||||
where
|
||||
ops :: AccumOps b
|
||||
ops :: AccumOps b (StateT (AccumMap b) (RestartT CheckOptM)) A.AST
|
||||
ops = applyAccum (undefined::b) allF
|
||||
|
||||
keepApplying' ::
|
||||
PolyplateMRoute t ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b, ())
|
||||
() (StateT (AccumMap b) (RestartT CheckOptM)) A.AST
|
||||
PolyplateMRoute t (b :-@ BaseOpMRoute)
|
||||
BaseOpMRoute
|
||||
=> ((t, Route t A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) (Either t t)) ->
|
||||
((t, Route t A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) t)
|
||||
keepApplying' f xr = do x' <- f xr
|
||||
|
|
@ -361,13 +359,12 @@ forAnyASTStructBottomUpAccum origF = CheckOptM $ do
|
|||
Left y -> do -- remove all sub-items from state,
|
||||
-- and then scan the item anew:
|
||||
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)
|
||||
|
||||
wrap :: forall a. (Data a,
|
||||
PolyplateMRoute (A.Structured a) () (AccumOps b) (StateT (AccumMap b) (RestartT CheckOptM)) A.AST
|
||||
, PolyplateMRoute (A.Structured a) ((b, Route b A.AST) -> StateT (AccumMap b) (RestartT CheckOptM) b, ())
|
||||
() (StateT (AccumMap b) (RestartT CheckOptM)) A.AST
|
||||
PolyplateMRoute (A.Structured a) BaseOpMRoute (AccumOps b)
|
||||
, PolyplateMRoute (A.Structured a) (b :-@ BaseOpMRoute) BaseOpMRoute
|
||||
) => ((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
|
||||
a) A.AST) -> StateT (AccumMap b) (RestartT
|
||||
|
|
@ -376,7 +373,7 @@ forAnyASTStructBottomUpAccum origF = CheckOptM $ do
|
|||
(routeId y) z))
|
||||
|
||||
allF
|
||||
= baseOp
|
||||
= baseOpMRoute
|
||||
`extOpMRoute` (wrap $ deCheckOptASTM' (origF :: (A.Structured A.Variant) ->
|
||||
CheckOptASTM' [b] (A.Structured A.Variant) ()))
|
||||
`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
|
||||
-- that are requested.
|
||||
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
|
||||
-- the given AST; from there, ops recurses for itself
|
||||
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
|
||||
Left _ -> do -- Restart
|
||||
tr' <- get >>* ast
|
||||
|
|
@ -412,15 +409,15 @@ doTree ops trans tr
|
|||
Right _ -> return ()
|
||||
|
||||
applyAccum :: forall t ops.
|
||||
PolyplateMRoute t () ((t, Route t A.AST) -> StateT (AccumMap t) (RestartT CheckOptM) t, ops)
|
||||
(StateT (AccumMap t) (RestartT CheckOptM)) A.AST
|
||||
=> t -> ops -> ((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
|
||||
applyAccum _ ops = ops'
|
||||
where
|
||||
ops' :: ((t, Route t A.AST) -> StateT (AccumMap t) (RestartT CheckOptM) t, ops)
|
||||
ops' = (accum, ops)
|
||||
ops' :: (t :-@ ops) (StateT (AccumMap t) (RestartT CheckOptM)) A.AST
|
||||
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'
|
||||
return x'
|
||||
|
||||
|
|
|
|||
|
|
@ -49,14 +49,14 @@ ok = return ()
|
|||
-- 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.
|
||||
checkTypes ::
|
||||
(PolyplateM t (OneOpM PassM A.Variable) () PassM
|
||||
,PolyplateM t (OneOpM PassM A.Expression) () PassM
|
||||
,PolyplateM t (OneOpM PassM A.SpecType) () PassM
|
||||
,PolyplateM t (OneOpM PassM A.Process) () PassM
|
||||
,PolyplateM t () (OneOpM PassM A.Variable) PassM
|
||||
,PolyplateM t () (OneOpM PassM A.Expression) PassM
|
||||
,PolyplateM t () (OneOpM PassM A.SpecType) PassM
|
||||
,PolyplateM t () (OneOpM PassM A.Process) PassM
|
||||
(PolyplateM t (OneOpM A.Variable) BaseOpM
|
||||
,PolyplateM t (OneOpM A.Expression) BaseOpM
|
||||
,PolyplateM t (OneOpM A.SpecType) BaseOpM
|
||||
,PolyplateM t (OneOpM A.Process) BaseOpM
|
||||
,PolyplateM t BaseOpM (OneOpM A.Variable)
|
||||
,PolyplateM t BaseOpM (OneOpM A.Expression)
|
||||
,PolyplateM t BaseOpM (OneOpM A.SpecType)
|
||||
,PolyplateM t BaseOpM (OneOpM A.Process)
|
||||
) => Pass t
|
||||
checkTypes = occamOnlyPass "Check types"
|
||||
[Prop.inferredTypesRecorded, Prop.ambiguitiesResolved]
|
||||
|
|
|
|||
|
|
@ -163,7 +163,7 @@ data InferTypeState = InferTypeState
|
|||
|
||||
type InferTypeM = StateT InferTypeState PassM
|
||||
|
||||
type ExtOpMI ops t = ExtOpM InferTypeM ops t
|
||||
type ExtOpMI ops t = t :-* ops
|
||||
|
||||
--{{{ type contexts
|
||||
|
||||
|
|
@ -193,7 +193,7 @@ getTypeContext
|
|||
-- 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.
|
||||
type InferTypeOps
|
||||
= ExtOpMS InferTypeM BaseOp
|
||||
= ExtOpMS BaseOpM
|
||||
`ExtOpMI` A.Expression
|
||||
`ExtOpMI` A.Dimension
|
||||
`ExtOpMI` A.Subscript
|
||||
|
|
@ -212,8 +212,8 @@ inferTypes = occamOnlyPass "Infer types"
|
|||
[Prop.inferredTypesRecorded]
|
||||
(flip evalStateT (InferTypeState [] []) . recurse)
|
||||
where
|
||||
ops :: InferTypeOps
|
||||
ops = baseOp
|
||||
ops :: InferTypeOps InferTypeM
|
||||
ops = baseOpM
|
||||
`extOpMS` (ops, doStructured)
|
||||
`extOpM` doExpression
|
||||
`extOpM` doDimension
|
||||
|
|
@ -365,14 +365,14 @@ inferTypes = occamOnlyPass "Infer types"
|
|||
= typeEqForOp 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]
|
||||
doActuals m n fs applyDir_Deref as
|
||||
= do lift $ checkActualCount m n fs as
|
||||
sequence [doActual m applyDir_Deref t a | (A.Formal _ t _, a) <- zip fs as]
|
||||
|
||||
-- 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
|
||||
doActual m (applyDir, _) (A.ChanEnd dir _ _) a = recurse a >>= applyDir m dir
|
||||
doActual m (_, deref) t a = inTypeContext (Just t) $ recurse a >>= deref t
|
||||
|
|
@ -458,8 +458,8 @@ inferTypes = occamOnlyPass "Infer types"
|
|||
mp' <- recurse mp
|
||||
return $ A.Variant m n iis' p' mp'
|
||||
|
||||
doStructured :: ( PolyplateM (A.Structured t) InferTypeOps () InferTypeM
|
||||
, PolyplateM (A.Structured t) () InferTypeOps InferTypeM
|
||||
doStructured :: ( PolyplateM (A.Structured t) InferTypeOps BaseOpM
|
||||
, PolyplateM (A.Structured t) BaseOpM InferTypeOps
|
||||
, Data t) => Infer (A.Structured t)
|
||||
|
||||
doStructured (A.Spec mspec s@(A.Specification m n st) body)
|
||||
|
|
@ -470,8 +470,8 @@ inferTypes = occamOnlyPass "Infer types"
|
|||
doStructured s = descend s
|
||||
|
||||
-- The second parameter is a modifier (wrapper) for the descent into the body
|
||||
doSpecType :: ( PolyplateM (A.Structured t) InferTypeOps () InferTypeM
|
||||
, PolyplateM (A.Structured t) () InferTypeOps InferTypeM
|
||||
doSpecType :: ( PolyplateM (A.Structured t) InferTypeOps BaseOpM
|
||||
, PolyplateM (A.Structured t) BaseOpM InferTypeOps
|
||||
, Data t) => A.Name -> A.SpecType -> ReaderT (A.Structured t) InferTypeM
|
||||
(A.SpecType, InferTypeM (A.Structured a) -> InferTypeM (A.Structured a))
|
||||
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.
|
||||
-- Normally we would do this pass in a StateT monad, but to slip inside
|
||||
-- PassM, I've used an IORef instead.
|
||||
findDir :: ( PolyplateM a InferTypeOps () InferTypeM
|
||||
, PolyplateM a () InferTypeOps InferTypeM
|
||||
findDir :: ( PolyplateM a InferTypeOps BaseOpM
|
||||
, PolyplateM a BaseOpM InferTypeOps
|
||||
) => A.Name -> a -> InferTypeM [A.Direction]
|
||||
findDir n x
|
||||
= do r <- liftIO $ newIORef []
|
||||
makeRecurseM (makeOps r) x
|
||||
liftIO $ readIORef r
|
||||
where
|
||||
makeOps :: IORef [A.Direction] -> InferTypeOps
|
||||
makeOps :: IORef [A.Direction] -> InferTypeOps InferTypeM
|
||||
makeOps r = ops
|
||||
where
|
||||
ops :: InferTypeOps
|
||||
ops = baseOp
|
||||
ops :: InferTypeOps InferTypeM
|
||||
ops = baseOpM
|
||||
`extOpMS` (ops, descend)
|
||||
`extOpM` descend
|
||||
`extOpM` descend
|
||||
|
|
|
|||
|
|
@ -248,7 +248,7 @@ foldConstants = occamOnlyPass "Fold constants"
|
|||
= do modifyName n (\nd -> nd { A.ndSpecType = st })
|
||||
return s
|
||||
|
||||
type CheckConstantsOps = BaseOp `ExtOpMP` A.Type `ExtOpMP` A.Option
|
||||
type CheckConstantsOps = BaseOpM `ExtOpMP` A.Type `ExtOpMP` A.Option
|
||||
`ExtOpMP` A.SpecType
|
||||
|
||||
-- | Check that things that must be constant are.
|
||||
|
|
@ -258,8 +258,8 @@ checkConstants = occamOnlyPass "Check mandatory constants"
|
|||
[Prop.constantsChecked]
|
||||
recurse
|
||||
where
|
||||
ops :: CheckConstantsOps
|
||||
ops = baseOp `extOpM` doType `extOpM` doOption `extOpM` doSpecType
|
||||
ops :: CheckConstantsOps PassM
|
||||
ops = baseOpM `extOpM` doType `extOpM` doOption `extOpM` doSpecType
|
||||
|
||||
descend :: DescendM PassM CheckConstantsOps
|
||||
descend = makeDescendM ops
|
||||
|
|
|
|||
|
|
@ -93,8 +93,8 @@ testFoldConstants = TestList
|
|||
, test 48 (add var (add const one)) (add var three)
|
||||
]
|
||||
where
|
||||
test :: (PolyplateM a (TwoOpM PassM A.Expression A.Specification) () PassM
|
||||
,PolyplateM a () (TwoOpM PassM A.Expression A.Specification) PassM
|
||||
test :: (PolyplateM a (TwoOpM A.Expression A.Specification) BaseOpM
|
||||
,PolyplateM a BaseOpM (TwoOpM A.Expression A.Specification)
|
||||
,Data a) => Int -> a -> a -> Test
|
||||
test n orig exp = TestCase $ testPass ("testFoldConstants" ++ show n)
|
||||
exp OccamPasses.foldConstants orig
|
||||
|
|
@ -142,15 +142,15 @@ testCheckConstants = TestList
|
|||
, testFail 33 (A.Option m [lit10, lit10, lit10, var] skip)
|
||||
]
|
||||
where
|
||||
testOK :: (PolyplateM a OccamPasses.CheckConstantsOps () PassM
|
||||
,PolyplateM a () OccamPasses.CheckConstantsOps PassM
|
||||
testOK :: (PolyplateM a OccamPasses.CheckConstantsOps BaseOpM
|
||||
,PolyplateM a BaseOpM OccamPasses.CheckConstantsOps
|
||||
,Show a, Data a) => Int -> a -> Test
|
||||
testOK n orig
|
||||
= TestCase $ testPass ("testCheckConstants" ++ show n)
|
||||
orig OccamPasses.checkConstants orig
|
||||
(return ())
|
||||
testFail :: (PolyplateM a OccamPasses.CheckConstantsOps () PassM
|
||||
,PolyplateM a () OccamPasses.CheckConstantsOps PassM
|
||||
testFail :: (PolyplateM a OccamPasses.CheckConstantsOps BaseOpM
|
||||
,PolyplateM a BaseOpM OccamPasses.CheckConstantsOps
|
||||
,Show a, Data a) => Int -> a -> Test
|
||||
testFail n orig
|
||||
= TestCase $ testPassShouldFail ("testCheckConstants" ++ show n)
|
||||
|
|
|
|||
|
|
@ -505,28 +505,28 @@ testOccamTypes = TestList
|
|||
--}}}
|
||||
]
|
||||
where
|
||||
testOK :: (PolyplateM a (OneOpM PassM A.Variable) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.Expression) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.SpecType) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.Process) () PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Variable) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Expression) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.SpecType) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Process) PassM
|
||||
testOK :: (PolyplateM a (OneOpM A.Variable) BaseOpM
|
||||
,PolyplateM a (OneOpM A.Expression) BaseOpM
|
||||
,PolyplateM a (OneOpM A.SpecType) BaseOpM
|
||||
,PolyplateM a (OneOpM A.Process) BaseOpM
|
||||
,PolyplateM a BaseOpM (OneOpM A.Variable)
|
||||
,PolyplateM a BaseOpM (OneOpM A.Expression)
|
||||
,PolyplateM a BaseOpM (OneOpM A.SpecType)
|
||||
,PolyplateM a BaseOpM (OneOpM A.Process)
|
||||
,Show a, Data a) => Int -> a -> Test
|
||||
testOK n orig
|
||||
= TestCase $ testPass ("testOccamTypes " ++ show n)
|
||||
orig OccamTypes.checkTypes orig
|
||||
startState
|
||||
|
||||
testFail :: (PolyplateM a (OneOpM PassM A.Variable) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.Expression) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.SpecType) () PassM
|
||||
,PolyplateM a (OneOpM PassM A.Process) () PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Variable) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Expression) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.SpecType) PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Process) PassM
|
||||
testFail :: (PolyplateM a (OneOpM A.Variable) BaseOpM
|
||||
,PolyplateM a (OneOpM A.Expression) BaseOpM
|
||||
,PolyplateM a (OneOpM A.SpecType) BaseOpM
|
||||
,PolyplateM a (OneOpM A.Process) BaseOpM
|
||||
,PolyplateM a BaseOpM (OneOpM A.Variable)
|
||||
,PolyplateM a BaseOpM (OneOpM A.Expression)
|
||||
,PolyplateM a BaseOpM (OneOpM A.SpecType)
|
||||
,PolyplateM a BaseOpM (OneOpM A.Process)
|
||||
,Show a, Data a) => Int -> a -> Test
|
||||
testFail n orig
|
||||
= TestCase $ testPassShouldFail ("testOccamTypes " ++ show n)
|
||||
|
|
|
|||
|
|
@ -61,11 +61,11 @@ type RainTypeM = StateT RainTypeState PassM
|
|||
|
||||
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 ()
|
||||
|
||||
type RainTypeCheckOn2 a b = forall t.
|
||||
(PolyplateM t (TwoOpM RainTypeM a b) () RainTypeM
|
||||
(PolyplateM t (TwoOpM a b) BaseOpM
|
||||
) => t -> RainTypeM ()
|
||||
|
||||
|
||||
|
|
@ -122,14 +122,14 @@ markUnify x y
|
|||
|
||||
performTypeUnification ::
|
||||
-- | A shorthand for prerequisites when you need to spell them out:
|
||||
(PolyplateM t (OneOpM RainTypeM A.Specification) () RainTypeM
|
||||
,PolyplateM t (OneOpM RainTypeM A.Process) () RainTypeM
|
||||
,PolyplateM t (OneOpM RainTypeM A.Expression) () RainTypeM
|
||||
,PolyplateM t (TwoOpM RainTypeM A.Process A.Expression) () RainTypeM
|
||||
,PolyplateM t (TwoOpM RainTypeM A.Process A.Choice) () RainTypeM
|
||||
,PolyplateM t (TwoOpM RainTypeM A.Process A.Alternative) () RainTypeM
|
||||
,PolyplateM t () (OneOpM PassM A.Type) PassM
|
||||
,PolyplateM t (OneOpM PassM A.Type) () PassM
|
||||
(PolyplateM t (OneOpM A.Specification) BaseOpM
|
||||
,PolyplateM t (OneOpM A.Process) BaseOpM
|
||||
,PolyplateM t (OneOpM A.Expression) BaseOpM
|
||||
,PolyplateM t (TwoOpM A.Process A.Expression) BaseOpM
|
||||
,PolyplateM t (TwoOpM A.Process A.Choice) BaseOpM
|
||||
,PolyplateM t (TwoOpM A.Process A.Alternative) BaseOpM
|
||||
,PolyplateM t BaseOpM (OneOpM A.Type)
|
||||
,PolyplateM t (OneOpM A.Type) BaseOpM
|
||||
) => Pass t
|
||||
performTypeUnification = rainOnlyPass "Rain Type Checking"
|
||||
([Prop.noInt] ++ Prop.agg_namesDone)
|
||||
|
|
|
|||
18
pass/Pass.hs
18
pass/Pass.hs
|
|
@ -97,21 +97,21 @@ instance Warn (ReaderT r PassM) where
|
|||
-- against AST fragments of other types as well.
|
||||
type PassType t = t -> PassM t
|
||||
|
||||
type PassOnOpsM m ops
|
||||
= (PolyplateM t ops () m, PolyplateM t () ops m) => Pass t
|
||||
type PassOnOpsM ops
|
||||
= (PolyplateM t ops BaseOpM, PolyplateM t BaseOpM ops) => Pass t
|
||||
|
||||
type PassOnOps ops = PassOnOpsM PassM ops
|
||||
type PassOnOps ops = PassOnOpsM 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
|
||||
= (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 PassOn2 s t = PassOnOps (TwoOpM PassM s t)
|
||||
type PassOnM2 m s t = PassOnOpsM m (TwoOpM m s t)
|
||||
type PassTypeOn t = PassTypeOnOps (OneOpM PassM t)
|
||||
type PassOn t = PassOnOps (OneOpM t)
|
||||
type PassOn2 s t = PassOnOps (TwoOpM s t)
|
||||
type PassOnM2 s t = PassOnOpsM (TwoOpM s t)
|
||||
type PassTypeOn t = PassTypeOnOps (OneOpM t)
|
||||
|
||||
-- | A description of an AST-mangling pass.
|
||||
data Pass t = Pass {
|
||||
|
|
|
|||
|
|
@ -51,77 +51,79 @@ type CheckM m t = t -> m ()
|
|||
-- | As 'CheckM', but specialised for 'PassM'.
|
||||
type Check t = CheckM PassM t
|
||||
|
||||
type ExtOpMP opT t = ExtOpM PassM opT t
|
||||
type ExtOpMP opT t = t :-* opT
|
||||
|
||||
type ExtOpMS m opT =
|
||||
(A.Structured () -> m (A.Structured ()),
|
||||
(A.Structured A.Alternative -> m (A.Structured A.Alternative),
|
||||
(A.Structured A.Choice -> m (A.Structured A.Choice),
|
||||
(A.Structured A.ExpressionList -> m (A.Structured A.ExpressionList),
|
||||
(A.Structured A.Option -> m (A.Structured A.Option),
|
||||
(A.Structured A.Process -> m (A.Structured A.Process),
|
||||
(A.Structured A.Variant -> m (A.Structured A.Variant),
|
||||
opT)))))))
|
||||
type ExtOpMSP opT = ExtOpMS PassM opT
|
||||
type ExtOpMS opT =
|
||||
(A.Structured ()) :-*
|
||||
(A.Structured A.Alternative) :-*
|
||||
(A.Structured A.Choice) :-*
|
||||
(A.Structured A.ExpressionList) :-*
|
||||
(A.Structured A.Option) :-*
|
||||
(A.Structured A.Process) :-*
|
||||
(A.Structured A.Variant) :-*
|
||||
opT
|
||||
|
||||
type PassOnStruct = PassOnOps (ExtOpMSP BaseOp)
|
||||
type PassASTOnStruct = PassASTOnOps (ExtOpMSP BaseOp)
|
||||
type ExtOpMSP opT = ExtOpMS opT PassM
|
||||
|
||||
class (PolyplateM (A.Structured a) () opsM m
|
||||
,PolyplateM (A.Structured a) opsM () m
|
||||
type PassOnStruct = PassOnOps (ExtOpMS BaseOpM)
|
||||
type PassASTOnStruct = PassASTOnOps (ExtOpMS BaseOpM)
|
||||
|
||||
class (PolyplateM (A.Structured a) BaseOpM opsM
|
||||
,PolyplateM (A.Structured a) opsM BaseOpM
|
||||
,Data a
|
||||
,Monad m
|
||||
) => ASTStructured a opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured ()) () opsM m
|
||||
,PolyplateM (A.Structured ()) opsM () m
|
||||
instance (PolyplateM (A.Structured ()) BaseOpM opsM
|
||||
,PolyplateM (A.Structured ()) opsM BaseOpM
|
||||
,Monad m) => ASTStructured () opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.Alternative) () opsM m
|
||||
,PolyplateM (A.Structured A.Alternative) opsM () m
|
||||
instance (PolyplateM (A.Structured A.Alternative) BaseOpM opsM
|
||||
,PolyplateM (A.Structured A.Alternative) opsM BaseOpM
|
||||
,Monad m) => ASTStructured A.Alternative opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.Choice) () opsM m
|
||||
,PolyplateM (A.Structured A.Choice) opsM () m
|
||||
instance (PolyplateM (A.Structured A.Choice) BaseOpM opsM
|
||||
,PolyplateM (A.Structured A.Choice) opsM BaseOpM
|
||||
,Monad m) => ASTStructured A.Choice opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.ExpressionList) () opsM m
|
||||
,PolyplateM (A.Structured A.ExpressionList) opsM () m
|
||||
instance (PolyplateM (A.Structured A.ExpressionList) BaseOpM opsM
|
||||
,PolyplateM (A.Structured A.ExpressionList) opsM BaseOpM
|
||||
,Monad m) => ASTStructured A.ExpressionList opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.Option) () opsM m
|
||||
,PolyplateM (A.Structured A.Option) opsM () m
|
||||
instance (PolyplateM (A.Structured A.Option) BaseOpM opsM
|
||||
,PolyplateM (A.Structured A.Option) opsM BaseOpM
|
||||
,Monad m) => ASTStructured A.Option opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.Process) () opsM m
|
||||
,PolyplateM (A.Structured A.Process) opsM () m
|
||||
instance (PolyplateM (A.Structured A.Process) BaseOpM opsM
|
||||
,PolyplateM (A.Structured A.Process) opsM BaseOpM
|
||||
,Monad m) => ASTStructured A.Process opsM m opsQ r
|
||||
|
||||
instance (PolyplateM (A.Structured A.Variant) () opsM m
|
||||
,PolyplateM (A.Structured A.Variant) opsM () m
|
||||
instance (PolyplateM (A.Structured A.Variant) BaseOpM opsM
|
||||
,PolyplateM (A.Structured A.Variant) opsM BaseOpM
|
||||
,Monad m) => ASTStructured A.Variant opsM m opsQ r
|
||||
|
||||
|
||||
extOpMS :: forall m opT op0T.
|
||||
(PolyplateM (A.Structured ()) () op0T m,
|
||||
PolyplateM (A.Structured A.Alternative) () op0T m,
|
||||
PolyplateM (A.Structured A.Choice) () op0T m,
|
||||
PolyplateM (A.Structured A.ExpressionList) () op0T m,
|
||||
PolyplateM (A.Structured A.Option) () op0T m,
|
||||
PolyplateM (A.Structured A.Process) () op0T m,
|
||||
PolyplateM (A.Structured A.Variant) () op0T m,
|
||||
PolyplateM (A.Structured ()) op0T () m,
|
||||
PolyplateM (A.Structured A.Alternative) op0T () m,
|
||||
PolyplateM (A.Structured A.Choice) op0T () m,
|
||||
PolyplateM (A.Structured A.ExpressionList) op0T () m,
|
||||
PolyplateM (A.Structured A.Option) op0T () m,
|
||||
PolyplateM (A.Structured A.Process) op0T () m,
|
||||
PolyplateM (A.Structured A.Variant) op0T () m) =>
|
||||
opT ->
|
||||
(PolyplateM (A.Structured ()) BaseOpM op0T,
|
||||
PolyplateM (A.Structured A.Alternative) BaseOpM op0T,
|
||||
PolyplateM (A.Structured A.Choice) BaseOpM op0T,
|
||||
PolyplateM (A.Structured A.ExpressionList) BaseOpM op0T,
|
||||
PolyplateM (A.Structured A.Option) BaseOpM op0T,
|
||||
PolyplateM (A.Structured A.Process) BaseOpM op0T,
|
||||
PolyplateM (A.Structured A.Variant) BaseOpM op0T,
|
||||
PolyplateM (A.Structured ()) op0T BaseOpM,
|
||||
PolyplateM (A.Structured A.Alternative) op0T BaseOpM,
|
||||
PolyplateM (A.Structured A.Choice) op0T BaseOpM,
|
||||
PolyplateM (A.Structured A.ExpressionList) op0T BaseOpM,
|
||||
PolyplateM (A.Structured A.Option) op0T BaseOpM,
|
||||
PolyplateM (A.Structured A.Process) op0T BaseOpM,
|
||||
PolyplateM (A.Structured A.Variant) op0T BaseOpM,
|
||||
Monad m) =>
|
||||
opT m ->
|
||||
-- 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)) ->
|
||||
ExtOpMS m opT
|
||||
ExtOpMS opT m
|
||||
extOpMS ops (_, f)
|
||||
= ops
|
||||
`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 () -> m (A.Structured ()))
|
||||
|
||||
applyBottomUpMS :: (PolyplateM t (ExtOpMSP BaseOp) () PassM) =>
|
||||
(forall a. (Data a, PolyplateM (A.Structured a) () (ExtOpMSP BaseOp) PassM) =>
|
||||
applyBottomUpMS :: (PolyplateM t (ExtOpMS BaseOpM) BaseOpM) =>
|
||||
(forall a. (Data a, PolyplateM (A.Structured a) BaseOpM (ExtOpMS BaseOpM)) =>
|
||||
(A.Structured a -> PassM (A.Structured a)))
|
||||
-> t -> PassM t
|
||||
applyBottomUpMS f = makeRecurseM ops
|
||||
where
|
||||
ops = baseOp `extOpMS` (ops, makeBottomUpM ops f)
|
||||
ops = baseOpM `extOpMS` (ops, makeBottomUpM ops f)
|
||||
|
||||
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
|
||||
= (PolyplateM (A.Structured t) () ops PassM
|
||||
,PolyplateM (A.Structured t) ops () PassM , Data t) => Transform (A.Structured t)
|
||||
= (PolyplateM (A.Structured t) BaseOpM ops
|
||||
,PolyplateM (A.Structured t) ops BaseOpM, Data t) => Transform (A.Structured t)
|
||||
|
||||
type TransformStructuredM' m ops
|
||||
= (PolyplateM (A.Structured t) () ops m
|
||||
,PolyplateM (A.Structured t) ops () m , Data t) => A.Structured t -> m (A.Structured t)
|
||||
= (PolyplateM (A.Structured t) BaseOpM ops
|
||||
,PolyplateM (A.Structured t) ops BaseOpM, Data t) => A.Structured t -> m (A.Structured t)
|
||||
|
|
|
|||
|
|
@ -178,8 +178,8 @@ import Data.Generics.Polyplate.Route
|
|||
--
|
||||
-- Generally you will not use this function or type-class directly, but will instead
|
||||
-- use the helper functions lower down in this module.
|
||||
class Monad m => PolyplateMRoute t o o' m outer where
|
||||
transformMRoute :: o m outer -> o' m outer -> (t, Route t outer) -> m t
|
||||
class PolyplateMRoute t o o' where
|
||||
transformMRoute :: Monad m => o m outer -> o' m outer -> (t, Route t outer) -> m t
|
||||
|
||||
-- | 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
|
||||
-- use the helper functions lower down in this module.
|
||||
class (Monad m) => PolyplateM t o o' m where
|
||||
transformM :: o m -> o' m -> t -> m t
|
||||
class PolyplateM t o o' where
|
||||
transformM :: (Monad m) => o m -> o' m -> t -> m t
|
||||
|
||||
|
||||
instance (Monad m
|
||||
, PolyplateMRoute t o o' m ()
|
||||
instance (
|
||||
PolyplateMRoute t o 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)
|
||||
(convertOpsToIgnoreRoute o')
|
||||
(t, fakeRoute t)
|
||||
|
|
@ -238,12 +238,12 @@ instance (Monad m
|
|||
class Polyplate t o o' where
|
||||
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)
|
||||
|
||||
-- | A type representing a monadic modifier function that applies the given ops
|
||||
-- (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),
|
||||
-- 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
|
||||
-- (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),
|
||||
-- makes a descent modifier function that applies the operation to the type's children.
|
||||
|
|
|
|||
|
|
@ -305,7 +305,7 @@ instancesFrom genOverlapped genClass boxes w
|
|||
-- and last arguments swapped.
|
||||
genInst :: [String] -> String -> String -> [String] -> [String]
|
||||
genInst context ops0 ops1 body
|
||||
= ["instance (Monad m" ++ concatMap (", " ++) context ++ ") =>"
|
||||
= ["instance (" ++ concat (intersperse ", " context) ++ ") =>"
|
||||
," " ++ contextSameType ops0 ops1 ++ " where"
|
||||
] ++ map (" " ++) body
|
||||
|
||||
|
|
@ -313,17 +313,17 @@ instancesFrom genOverlapped genClass boxes w
|
|||
-- sets. The class name will be the same as genInst.
|
||||
contextSameType :: String -> String -> String
|
||||
contextSameType ops0 ops1 = case genClass of
|
||||
GenOneClass -> "PolyplateMRoute (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m outer"
|
||||
GenClassPerType -> "PolyplateMRoute" ++ wMunged ++" " ++ ops0 ++ " " ++ ops1 ++ " m outer"
|
||||
GenSlowDelegate -> "PolyplateMRoute' m " ++ ops0 ++ " " ++ ops1 ++ " (" ++ wName ++ ") outer"
|
||||
GenOneClass -> "PolyplateMRoute (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1
|
||||
GenClassPerType -> "PolyplateMRoute" ++ wMunged ++" " ++ ops0 ++ " " ++ ops1
|
||||
GenSlowDelegate -> "PolyplateMRoute' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ wName ++ ")"
|
||||
|
||||
-- Generates the name of an instance for a different type (for processing children).
|
||||
-- This will be PolyplateM or PolyplateM'.
|
||||
contextNewType :: String -> String -> String -> String
|
||||
contextNewType cName ops0 ops1 = case genClass of
|
||||
GenOneClass -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m outer"
|
||||
GenClassPerType -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1 ++ " m outer"
|
||||
GenSlowDelegate -> "PolyplateMRoute' m " ++ ops0 ++ " " ++ ops1 ++ " (" ++ cName ++ ") outer"
|
||||
GenOneClass -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1
|
||||
GenClassPerType -> "PolyplateMRoute (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1
|
||||
GenSlowDelegate -> "PolyplateMRoute' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ cName ++ ")"
|
||||
|
||||
|
||||
-- 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"
|
||||
[funcSameType ++ " (_ :-@ rest) ops vr = " ++ funcSameType ++ " rest ops vr"]
|
||||
,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
|
||||
++ ", Route (" ++ wName ++ ") outer) -> m (" ++ wName ++ ")"
|
||||
,""
|
||||
,"instance (Monad m, " ++ contextSameType "o0" "o1" ++ ") =>"
|
||||
," PolyplateMRoute (" ++ wName ++ ") o0 o1 m outer where"
|
||||
,"instance (" ++ contextSameType "o0" "o1" ++ ") =>"
|
||||
," PolyplateMRoute (" ++ wName ++ ") o0 o1 where"
|
||||
," transformMRoute = " ++ funcSameType
|
||||
]
|
||||
else []
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
-- This can be used to perform a bottom-up depth-first traversal of a structure
|
||||
-- (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
|
||||
|
||||
-- | 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
|
||||
makeBottomUpMRoute ops f (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.
|
||||
-- This can be used to perform a top-down depth-first traversal of a structure
|
||||
-- (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
|
||||
|
||||
-- | 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
|
||||
makeTopDownMRoute ops 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
|
||||
-- larger item (of type \"t\") that satisfy this function, listed in depth-first
|
||||
-- order.
|
||||
listifyDepth :: (PolyplateM t (OneOpM s) BaseOpM (State [s])
|
||||
,PolyplateM s BaseOpM (OneOpM s) (State [s])) => (s -> Bool) -> t -> [s]
|
||||
listifyDepth :: (PolyplateM t (OneOpM s) BaseOpM
|
||||
,PolyplateM s BaseOpM (OneOpM s)) => (s -> Bool) -> t -> [s]
|
||||
-- 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
|
||||
-- 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
|
||||
|
||||
-- | Like listifyDepth, but with routes
|
||||
listifyDepthRoute :: (PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute) (State [(s, Route s t)]) t
|
||||
,PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s) (State [(s, Route s t)]) t)
|
||||
listifyDepthRoute :: (PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute)
|
||||
,PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s))
|
||||
=> ((s, Route s t) -> Bool) -> t -> [(s, Route s t)]
|
||||
listifyDepthRoute qf = flip execState [] . applyBottomUpMRoute qf'
|
||||
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,
|
||||
-- or to accumulate information in a state monad.
|
||||
checkDepthM :: (Monad m, PolyplateM t (OneOpM s) BaseOpM m
|
||||
, PolyplateM s BaseOpM (OneOpM s) m) => (s -> m ()) -> t -> m ()
|
||||
checkDepthM :: (Monad m, PolyplateM t (OneOpM s) BaseOpM
|
||||
, PolyplateM s BaseOpM (OneOpM s)) => (s -> m ()) -> t -> m ()
|
||||
checkDepthM f x = applyBottomUpM (\x -> f x >> return x) x >> return ()
|
||||
|
||||
-- | As 'checkDepthM', but takes two functions (one operating on type \"r\", the
|
||||
-- other on type \"s\").
|
||||
checkDepthM2 :: (Monad m, PolyplateM t (TwoOpM r s) (BaseOpM) m
|
||||
, PolyplateM r (BaseOpM) (TwoOpM r s) m
|
||||
, PolyplateM s (BaseOpM) (TwoOpM r s) m
|
||||
checkDepthM2 :: (Monad m, PolyplateM t (TwoOpM r s) (BaseOpM)
|
||||
, PolyplateM r (BaseOpM) (TwoOpM r s)
|
||||
, PolyplateM s (BaseOpM) (TwoOpM r s)
|
||||
) =>
|
||||
(r -> m ()) -> (s -> m ()) -> t -> m ()
|
||||
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
|
||||
-- the generated instances, not your own), descending first and applying the function
|
||||
-- afterwards on the way back up.
|
||||
applyBottomUpM :: (PolyplateM t (OneOpM s) BaseOpM m,
|
||||
PolyplateM s BaseOpM (OneOpM s) m) =>
|
||||
applyBottomUpM :: (PolyplateM t (OneOpM s) BaseOpM,
|
||||
PolyplateM s BaseOpM (OneOpM s), Monad m) =>
|
||||
(s -> m s) -> t -> m t
|
||||
applyBottomUpM f = makeRecurseM ops
|
||||
where
|
||||
ops = baseOpM `extOpM` makeBottomUpM ops f
|
||||
|
||||
applyBottomUpMRoute :: forall m s t.
|
||||
(PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute) m t,
|
||||
PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s) m t) =>
|
||||
(PolyplateMRoute t (OneOpMRoute s) (BaseOpMRoute),
|
||||
PolyplateMRoute s (BaseOpMRoute) (OneOpMRoute s),
|
||||
Monad m) =>
|
||||
((s, Route s t) -> m s) -> t -> m t
|
||||
applyBottomUpMRoute f x = transformMRoute ops base (x, identityRoute)
|
||||
where
|
||||
|
|
@ -158,9 +159,10 @@ applyBottomUpMRoute f x = transformMRoute ops base (x, identityRoute)
|
|||
|
||||
-- | As 'applyBottomUpM', but applies two functions. These should not be modifying
|
||||
-- the same type.
|
||||
applyBottomUpM2 :: (PolyplateM t (TwoOpM sA sB) (BaseOpM) m,
|
||||
PolyplateM sA (BaseOpM) (TwoOpM sA sB) m,
|
||||
PolyplateM sB (BaseOpM) (TwoOpM sA sB) m
|
||||
applyBottomUpM2 :: (PolyplateM t (TwoOpM sA sB) (BaseOpM),
|
||||
PolyplateM sA (BaseOpM) (TwoOpM sA sB),
|
||||
PolyplateM sB (BaseOpM) (TwoOpM sA sB),
|
||||
Monad m
|
||||
) =>
|
||||
(sA -> m sA) -> (sB -> m sB) -> t -> m t
|
||||
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
|
||||
-- the generated instances, not your own), applying the function first and then
|
||||
-- descending.
|
||||
applyTopDownM :: (PolyplateM t (s :-* BaseOpM) BaseOpM m,
|
||||
PolyplateM s BaseOpM (s :-* BaseOpM) m) =>
|
||||
applyTopDownM :: (PolyplateM t (s :-* BaseOpM) BaseOpM,
|
||||
PolyplateM s BaseOpM (s :-* BaseOpM),
|
||||
Monad m) =>
|
||||
(s -> m s) -> t -> m t
|
||||
applyTopDownM f = makeRecurseM ops
|
||||
where
|
||||
|
|
@ -199,9 +202,10 @@ applyTopDownM f = makeRecurseM ops
|
|||
|
||||
-- | As applyTopDownM, but applies two functions. These should not be modifying
|
||||
-- the same type.
|
||||
applyTopDownM2 :: (PolyplateM t (sA :-* sB :-* BaseOpM) BaseOpM m,
|
||||
PolyplateM sA BaseOpM (sA :-* sB :-* BaseOpM) m,
|
||||
PolyplateM sB BaseOpM (sA :-* sB :-* BaseOpM) m
|
||||
applyTopDownM2 :: (PolyplateM t (sA :-* sB :-* BaseOpM) BaseOpM,
|
||||
PolyplateM sA BaseOpM (sA :-* sB :-* BaseOpM),
|
||||
PolyplateM sB BaseOpM (sA :-* sB :-* BaseOpM),
|
||||
Monad m
|
||||
) =>
|
||||
(sA -> m sA) -> (sB -> m sB) -> t -> m t
|
||||
applyTopDownM2 fA fB = makeRecurseM ops
|
||||
|
|
|
|||
|
|
@ -203,15 +203,15 @@ implicitMobility
|
|||
mobiliseArrays :: PassASTOnStruct
|
||||
mobiliseArrays = pass "Make all arrays mobile" [] [] recurse
|
||||
where
|
||||
ops :: ExtOpMSP BaseOp
|
||||
ops = baseOp `extOpMS` (ops, doStructured)
|
||||
ops :: ExtOpMSP BaseOpM
|
||||
ops = baseOpM `extOpMS` (ops, doStructured)
|
||||
|
||||
recurse :: RecurseM PassM (ExtOpMSP BaseOp)
|
||||
recurse :: RecurseM PassM (ExtOpMS BaseOpM)
|
||||
recurse = makeRecurseM ops
|
||||
descend :: DescendM PassM (ExtOpMSP BaseOp)
|
||||
descend :: DescendM PassM (ExtOpMS BaseOpM)
|
||||
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
|
||||
innerT))) scope)
|
||||
= case innerT of
|
||||
|
|
@ -309,11 +309,11 @@ instance Dereferenceable A.Actual where
|
|||
inferDeref :: PassOn2 A.Process A.Variable
|
||||
inferDeref = pass "Infer mobile dereferences" [] [] recurse
|
||||
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
|
||||
descend :: DescendM PassM (TwoOpM PassM A.Process A.Variable)
|
||||
descend :: DescendM PassM (TwoOpM A.Process A.Variable)
|
||||
descend = makeDescendM ops
|
||||
|
||||
unify :: (Dereferenceable a, ASTTypeable a, ShowOccam a, ShowRain a) => Meta
|
||||
|
|
|
|||
|
|
@ -49,14 +49,14 @@ simplifyAbbrevs =
|
|||
]
|
||||
|
||||
-- | Rewrite 'InitialAbbrev' into a variable and an assignment.
|
||||
removeInitial :: PassOnOps (ExtOpMSP BaseOp)
|
||||
removeInitial :: PassOnOps (ExtOpMS BaseOpM)
|
||||
removeInitial
|
||||
= pass "Remove INITIAL abbreviations"
|
||||
[]
|
||||
[Prop.initialRemoved]
|
||||
(applyBottomUpMS doStructured)
|
||||
where
|
||||
doStructured :: TransformStructured (ExtOpMSP BaseOp)
|
||||
doStructured :: TransformStructured (ExtOpMS BaseOpM)
|
||||
doStructured (A.Spec m spec s) = doSpec m spec s
|
||||
doStructured s = return s
|
||||
|
||||
|
|
@ -191,20 +191,20 @@ updateAbbrevsInState
|
|||
doAbbrevMode s = s
|
||||
|
||||
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
|
||||
= pass "Abbreviation checking" [] []
|
||||
({-passOnlyOnAST "abbrevCheck" $ -} flip evalStateT [Map.empty] . recurse)
|
||||
where
|
||||
ops :: AbbrevCheckOps
|
||||
ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doVariable
|
||||
ops :: AbbrevCheckOps AbbrevCheckM
|
||||
ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doVariable
|
||||
`extOpM` doProcess `extOpM` doInputItem
|
||||
|
||||
descend :: DescendM AbbrevCheckM AbbrevCheckOps
|
||||
|
|
@ -212,7 +212,7 @@ abbrevCheckPass
|
|||
recurse :: RecurseM AbbrevCheckM AbbrevCheckOps
|
||||
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
|
||||
pop :: StateT [Map.Map Var Bool] PassM ()
|
||||
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
|
||||
-- pragma
|
||||
|
||||
doStructured :: (PolyplateM (A.Structured t) () AbbrevCheckOps AbbrevCheckM
|
||||
,PolyplateM (A.Structured t) AbbrevCheckOps () AbbrevCheckM, Data t) =>
|
||||
doStructured :: (PolyplateM (A.Structured t) BaseOpM AbbrevCheckOps
|
||||
,PolyplateM (A.Structured t) AbbrevCheckOps BaseOpM, Data t) =>
|
||||
A.Structured t -> AbbrevCheckM (A.Structured t)
|
||||
doStructured s@(A.Spec _ (A.Specification _ n (A.Is _ A.Abbrev _ (A.ActualVariable v))) scope)
|
||||
= do nonce <- nameIsNonce n
|
||||
|
|
|
|||
|
|
@ -94,8 +94,8 @@ testRemoveInitial = TestLabel "testRemoveInitial" $ TestList
|
|||
inner)
|
||||
]
|
||||
where
|
||||
ok :: (PolyplateM a (ExtOpMSP BaseOp) () PassM
|
||||
,PolyplateM a () (ExtOpMSP BaseOp) PassM
|
||||
ok :: (PolyplateM a (ExtOpMS BaseOpM) BaseOpM
|
||||
,PolyplateM a BaseOpM (ExtOpMS BaseOpM)
|
||||
,Data a, Data b) => Int -> a -> b -> Test
|
||||
ok n inp exp = TestCase $ testPass ("testRemoveInitial" ++ show n)
|
||||
exp removeInitial inp setupState
|
||||
|
|
@ -152,7 +152,7 @@ testRemoveResult = TestLabel "testRemoveResult" $ TestList
|
|||
(A.Formal A.Abbrev A.Int foo)
|
||||
]
|
||||
where
|
||||
ok :: (Polyplate a (OneOp A.AbbrevMode) ()
|
||||
ok :: (Polyplate a (OneOp A.AbbrevMode) BaseOp
|
||||
,Data a, Data b) => Int -> a -> b -> Test
|
||||
ok n inp exp = TestCase $ testPass ("testRemoveResult" ++ show n)
|
||||
exp removeResult inp setupState
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
pullRepCountProc p = return p
|
||||
|
||||
transformConstr :: PassOnOps (ExtOpMSP BaseOp)
|
||||
transformConstr :: PassOnOps (ExtOpMS BaseOpM)
|
||||
transformConstr = pass "Transform array constructors into initialisation code"
|
||||
(Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.subscriptsPulledUp])
|
||||
[Prop.arrayConstructorsRemoved]
|
||||
|
|
@ -323,7 +323,7 @@ transformConstr = pass "Transform array constructors into initialisation code"
|
|||
|
||||
doStructured s = return s
|
||||
|
||||
type PullUpOps = ExtOpMSP BaseOp
|
||||
type PullUpOps = ExtOpMS BaseOpM
|
||||
`ExtOpMP` A.Process
|
||||
`ExtOpMP` A.Structured A.Expression
|
||||
`ExtOpMP` A.Specification
|
||||
|
|
@ -340,8 +340,8 @@ pullUp pullUpArraysInsideRecords = pass "Pull up definitions"
|
|||
[Prop.functionCallsRemoved, Prop.subscriptsPulledUp]
|
||||
recurse
|
||||
where
|
||||
ops :: PullUpOps
|
||||
ops = baseOp
|
||||
ops :: PullUpOps PassM
|
||||
ops = baseOpM
|
||||
`extOpMS` (ops, doStructured)
|
||||
`extOpM` doProcess
|
||||
`extOpM` doRepArray
|
||||
|
|
|
|||
|
|
@ -45,15 +45,15 @@ simplifyProcs =
|
|||
]
|
||||
|
||||
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
|
||||
addForkNames :: PassOnOpsM ForkM ForkOps
|
||||
addForkNames :: PassOnOpsM ForkOps
|
||||
addForkNames = occamOnlyPass "Add FORK labels" [] []
|
||||
(flip evalStateT [] . recurse)
|
||||
where
|
||||
ops :: ForkOps
|
||||
ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doProcess
|
||||
ops :: ForkOps ForkM
|
||||
ops = baseOpM `extOpMS` (ops, doStructured) `extOpM` doProcess
|
||||
|
||||
recurse :: RecurseM ForkM ForkOps
|
||||
recurse = makeRecurseM ops
|
||||
|
|
@ -153,14 +153,14 @@ removeParAssign = pass "Remove parallel assignment"
|
|||
doProcess p = return p
|
||||
|
||||
-- | 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"
|
||||
(Prop.agg_typesDone ++ [Prop.assignParRemoved])
|
||||
[Prop.assignFlattened]
|
||||
(makeRecurseM ops)
|
||||
where
|
||||
ops = baseOp `extOpMS` (ops, makeBottomUpM ops doStructured)
|
||||
`extOpM` makeBottomUpM ops doProcess
|
||||
ops = baseOpM `extOpMS` (ops, makeBottomUpM ops doStructured)
|
||||
`extOpM` makeBottomUpM ops doProcess
|
||||
|
||||
doProcess :: A.Process -> PassM A.Process
|
||||
doProcess (A.Assign m [v] (A.ExpressionList m' [e]))
|
||||
|
|
|
|||
|
|
@ -51,8 +51,8 @@ testResolveNamedTypes = TestLabel "testResolveNamedTypes" $ TestList
|
|||
(array10 A.Int)
|
||||
]
|
||||
where
|
||||
ok :: (PolyplateM a (OneOpM PassM A.Type) () PassM
|
||||
,PolyplateM a () (OneOpM PassM A.Type) PassM
|
||||
ok :: (PolyplateM a (OneOpM A.Type) BaseOpM
|
||||
,PolyplateM a BaseOpM (OneOpM A.Type)
|
||||
,Data a, Data b) => Int -> a -> b -> Test
|
||||
ok n inp exp = TestCase $ testPass ("testResolveNamedTypes" ++ show n)
|
||||
exp resolveNamedTypes inp setupState
|
||||
|
|
|
|||
|
|
@ -48,22 +48,22 @@ type NameMap = 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.
|
||||
freeNamesIn :: PolyplateM t FreeNameOps () FreeNameM => t -> NameMap
|
||||
freeNamesIn :: PolyplateM t FreeNameOps BaseOpM => t -> NameMap
|
||||
freeNamesIn = flip execState Map.empty . recurse
|
||||
where
|
||||
flattenTree :: Tree (Maybe NameMap) -> NameMap
|
||||
flattenTree = foldl Map.union Map.empty . catMaybes . flatten
|
||||
|
||||
ops :: FreeNameOps
|
||||
ops = baseOp `extOpM` doName `extOpMS` (ops, doStructured) `extOpM` doSpecType
|
||||
ops :: FreeNameOps FreeNameM
|
||||
ops = baseOpM `extOpM` doName `extOpMS` (ops, doStructured) `extOpM` doSpecType
|
||||
|
||||
recurse :: PolyplateM t FreeNameOps () FreeNameM => t -> FreeNameM t
|
||||
recurse = transformM ops ()
|
||||
descend :: PolyplateM t () FreeNameOps FreeNameM => t -> FreeNameM t
|
||||
descend = transformM () ops
|
||||
recurse :: PolyplateM t FreeNameOps BaseOpM => t -> FreeNameM t
|
||||
recurse = transformM ops baseOpM
|
||||
descend :: PolyplateM t BaseOpM FreeNameOps => t -> FreeNameM t
|
||||
descend = transformM baseOpM ops
|
||||
|
||||
ignore :: t -> NameMap
|
||||
ignore s = Map.empty
|
||||
|
|
@ -71,15 +71,15 @@ freeNamesIn = flip execState Map.empty . recurse
|
|||
doName :: A.Name -> FreeNameM A.Name
|
||||
doName n = modify (Map.insert (A.nameName n) n) >> return n
|
||||
|
||||
doStructured :: (Data a, PolyplateM (A.Structured a) () FreeNameOps FreeNameM
|
||||
, PolyplateM (A.Structured a) FreeNameOps () FreeNameM
|
||||
doStructured :: (Data a, PolyplateM (A.Structured a) BaseOpM FreeNameOps
|
||||
, PolyplateM (A.Structured a) FreeNameOps BaseOpM
|
||||
)
|
||||
=> A.Structured a -> FreeNameM (A.Structured a)
|
||||
doStructured x@(A.Spec _ spec s) = doSpec spec s >> return x
|
||||
doStructured s = descend s
|
||||
|
||||
doSpec :: (PolyplateM t () FreeNameOps FreeNameM
|
||||
,PolyplateM t FreeNameOps () FreeNameM) => A.Specification -> t -> FreeNameM ()
|
||||
doSpec :: (PolyplateM t BaseOpM FreeNameOps
|
||||
,PolyplateM t FreeNameOps BaseOpM) => A.Specification -> t -> FreeNameM ()
|
||||
doSpec (A.Specification _ n st) child
|
||||
= modify (Map.union $ Map.union fns $ Map.delete (A.nameName n) $ freeNamesIn child)
|
||||
where
|
||||
|
|
@ -98,15 +98,15 @@ freeNamesIn = flip execState Map.empty . recurse
|
|||
-- 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
|
||||
-- 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
|
||||
where
|
||||
smap = Map.fromList [(A.nameName f, t) | (f, t) <- map]
|
||||
|
||||
ops :: TwoOpM PassM A.Name A.Specification
|
||||
ops = baseOp `extOpM` doName `extOpM` doSpecification
|
||||
ops :: TwoOpM A.Name A.Specification PassM
|
||||
ops = doName :-* doSpecification :-* baseOpM
|
||||
|
||||
recurse :: RecurseM PassM (TwoOpM PassM A.Name A.Specification)
|
||||
recurse :: RecurseM PassM (TwoOpM A.Name A.Specification)
|
||||
recurse = makeRecurseM ops
|
||||
|
||||
doName :: Transform A.Name
|
||||
|
|
@ -124,7 +124,7 @@ replaceNames map = recurse
|
|||
return $ A.Specification m n' sp'
|
||||
|
||||
-- | 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"
|
||||
[Prop.mainTagged, Prop.parsWrapped, Prop.functionCallsRemoved]
|
||||
[Prop.freeNamesToArgs]
|
||||
|
|
@ -213,7 +213,7 @@ removeFreeNames = pass "Convert free names to arguments"
|
|||
doProcess p = return p
|
||||
|
||||
-- | Pull nested declarations to the top level.
|
||||
removeNesting :: PassASTOnOps (ExtOpMSP BaseOp)
|
||||
removeNesting :: PassASTOnOps (ExtOpMS BaseOpM)
|
||||
removeNesting = pass "Pull nested definitions to top level"
|
||||
[Prop.freeNamesToArgs]
|
||||
[Prop.nestedPulled]
|
||||
|
|
@ -223,16 +223,16 @@ removeNesting = pass "Pull nested definitions to top level"
|
|||
popPullContext
|
||||
return s')
|
||||
where
|
||||
ops :: ExtOpMSP BaseOp
|
||||
ops = baseOp `extOpMS` (ops, doStructured)
|
||||
ops :: ExtOpMSP BaseOpM
|
||||
ops = baseOpM `extOpMS` (ops, doStructured)
|
||||
|
||||
|
||||
recurse :: RecurseM PassM (ExtOpMSP BaseOp)
|
||||
recurse :: RecurseM PassM (ExtOpMS BaseOpM)
|
||||
recurse = makeRecurseM ops
|
||||
descend :: DescendM PassM (ExtOpMSP BaseOp)
|
||||
descend :: DescendM PassM (ExtOpMS BaseOpM)
|
||||
descend = makeDescendM ops
|
||||
|
||||
doStructured :: TransformStructured (ExtOpMSP BaseOp)
|
||||
doStructured :: TransformStructured (ExtOpMS BaseOpM)
|
||||
doStructured s@(A.Spec m spec subS)
|
||||
= do spec'@(A.Specification _ n st) <- recurse spec
|
||||
isConst <- isConstantName n
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user