+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'
+
+addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
+addTickLCmdStmts stmts = do
+ (stmts, _) <- addTickLCmdStmts' stmts (return ())
+ return stmts
+
+addTickLCmdStmts' :: [LStmt Id] -> TM a -> TM ([LStmt Id], a)
+addTickLCmdStmts' lstmts res
+ = bindLocals binders $ do
+ lstmts' <- mapM (liftL addTickCmdStmt) lstmts
+ a <- res
+ return (lstmts', a)
+ where
+ binders = collectLStmtsBinders lstmts
+
+addTickCmdStmt :: Stmt Id -> TM (Stmt Id)
+addTickCmdStmt (BindStmt pat c bind fail) = do
+ liftM4 BindStmt
+ (addTickLPat pat)
+ (addTickLHsCmd c)
+ (return bind)
+ (return fail)
+addTickCmdStmt (ExprStmt c bind' ty) = do
+ liftM3 ExprStmt
+ (addTickLHsCmd c)
+ (return bind')
+ (return ty)
+addTickCmdStmt (LetStmt binds) = do
+ liftM LetStmt
+ (addTickHsLocalBinds binds)
+addTickCmdStmt stmt@(RecStmt {})
+ = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
+ ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
+ ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
+ ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
+ ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
+ , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
+
+-- Others should never happen in a command context.
+addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)