- return a = TM $ \ st -> (a,st)
- (TM m) >>= k = TM $ \ st -> case m st of
- (r1,st1) -> unTM (k r1) st1
-
---addTick :: LHsExpr Id -> TM (LHsExpr Id)
---addTick e = TM $ \ uq -> (e,succ uq,[(uq,getLoc e)])
+ return a = TM $ \ env st -> (a,noFVs,st)
+ (TM m) >>= k = TM $ \ env st ->
+ case m env st of
+ (r1,fv1,st1) ->
+ case unTM (k r1) env st1 of
+ (r2,fv2,st2) ->
+ (r2, fv1 `plusOccEnv` fv2, st2)
+
+-- getState :: TM TickTransState
+-- getState = TM $ \ env st -> (st, noFVs, st)
+
+setState :: (TickTransState -> TickTransState) -> TM ()
+setState f = TM $ \ env st -> ((), noFVs, f st)
+
+getEnv :: TM TickTransEnv
+getEnv = TM $ \ env st -> (env, noFVs, st)
+
+withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
+withEnv f (TM m) = TM $ \ env st ->
+ case m (f env) st of
+ (a, fvs, st') -> (a, fvs, st')
+
+getFreeVars :: TM a -> TM (FreeVars, a)
+getFreeVars (TM m)
+ = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
+
+freeVar :: Id -> TM ()
+freeVar id = TM $ \ env st ->
+ if id `elemVarSet` inScope env
+ then ((), unitOccEnv (nameOccName (idName id)) id, st)
+ else ((), noFVs, st)