- liftM ParStmt (mapM process pairs)
- where
- process (stmts,ids) =
- liftM2 (,)
- (addTickLStmts isGuard stmts)
- (return ids)
-addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
- liftM5 RecStmt
- (addTickLStmts isGuard stmts)
- (return ids1)
- (return ids2)
- (return tys)
- (addTickDictBinds dictbinds)
+ liftM ParStmt
+ (mapM (addTickStmtAndBinders isGuard) pairs)
+
+addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr) = do
+ liftM4 TransformStmt
+ (addTickLStmts isGuard stmts)
+ (return ids)
+ (addTickLHsExprAlways usingExpr)
+ (addTickMaybeByLHsExpr maybeByExpr)
+
+addTickStmt isGuard (GroupStmt stmts binderMap by using) = do
+ liftM4 GroupStmt
+ (addTickLStmts isGuard stmts)
+ (return binderMap)
+ (fmapMaybeM addTickLHsExprAlways by)
+ (fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using)
+
+addTickStmt isGuard stmt@(RecStmt {})
+ = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
+ ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
+ ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
+ ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
+ ; dicts' <- addTickEvBinds (recS_dicts stmt)
+ ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
+ , recS_mfix_fn = mfix', recS_bind_fn = bind'
+ , recS_dicts = dicts' }) }
+
+addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
+addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
+ | otherwise = addTickLHsExprAlways e
+
+addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a)
+ -> TM ([LStmt Id], a)
+addTickStmtAndBinders isGuard (stmts, ids) =
+ liftM2 (,)
+ (addTickLStmts isGuard stmts)
+ (return ids)
+
+addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
+addTickMaybeByLHsExpr maybeByExpr =
+ case maybeByExpr of
+ Nothing -> return Nothing
+ Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)