+addTickLHsCmd (L pos c0) = do
+ c1 <- addTickHsCmd c0
+ return $ L pos c1
+
+addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
+addTickHsCmd (HsLam matchgroup) =
+ liftM HsLam (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsApp e1 e2) =
+ liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
+addTickHsCmd (OpApp e1 c2 fix c3) =
+ liftM4 OpApp
+ (addTickLHsExpr e1)
+ (addTickLHsCmd c2)
+ (return fix)
+ (addTickLHsCmd c3)
+addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
+addTickHsCmd (HsCase e mgs) =
+ liftM2 HsCase
+ (addTickLHsExpr e)
+ (addTickCmdMatchGroup mgs)
+addTickHsCmd (HsIf cnd e1 c2 c3) =
+ liftM3 (HsIf cnd)
+ (addBinTickLHsExpr (BinBox CondBinBox) e1)
+ (addTickLHsCmd c2)
+ (addTickLHsCmd c3)
+addTickHsCmd (HsLet binds c) =
+ bindLocals (collectLocalBinders binds) $
+ liftM2 HsLet
+ (addTickHsLocalBinds binds) -- to think about: !patterns.
+ (addTickLHsCmd c)
+addTickHsCmd (HsDo cxt stmts last_exp srcloc) = do
+ (stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp)
+ return (HsDo cxt stmts' last_exp' srcloc)
+ where
+addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
+ liftM5 HsArrApp
+ (addTickLHsExpr e1)
+ (addTickLHsExpr e2)
+ (return ty1)
+ (return arr_ty)
+ (return lr)
+addTickHsCmd (HsArrForm e fix cmdtop) =
+ liftM3 HsArrForm
+ (addTickLHsExpr e)
+ (return fix)
+ (mapM (liftL (addTickHsCmdTop)) cmdtop)
+
+-- Others should never happen in a command context.
+addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
+
+addTickCmdMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
+addTickCmdMatchGroup (MatchGroup matches ty) = do
+ matches' <- mapM (liftL addTickCmdMatch) matches
+ return $ MatchGroup matches' ty
+
+addTickCmdMatch :: Match Id -> TM (Match Id)
+addTickCmdMatch (Match pats opSig gRHSs) =
+ bindLocals (collectPatsBinders pats) $ do
+ gRHSs' <- addTickCmdGRHSs gRHSs
+ return $ Match pats opSig gRHSs'
+
+addTickCmdGRHSs :: GRHSs Id -> TM (GRHSs Id)
+addTickCmdGRHSs (GRHSs guarded local_binds) = do
+ bindLocals binders $ do
+ local_binds' <- addTickHsLocalBinds local_binds
+ guarded' <- mapM (liftL addTickCmdGRHS) guarded
+ return $ GRHSs guarded' local_binds'
+ where
+ binders = collectLocalBinders local_binds
+
+addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
+addTickCmdGRHS (GRHS stmts cmd) = do
+ (stmts',expr') <- addTickLCmdStmts' stmts (addTickLHsCmd cmd)
+ return $ GRHS stmts' expr'