diff options
Diffstat (limited to 'compiler/deSugar/Coverage.hs')
| -rw-r--r-- | compiler/deSugar/Coverage.hs | 32 |
1 files changed, 18 insertions, 14 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index a5faef0201..9b7c87397f 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -592,8 +592,9 @@ addTickHsExpr (ExplicitList ty wit es) = (addTickWit wit) (mapM (addTickLHsExpr) es) where addTickWit Nothing = return Nothing - addTickWit (Just fln) = do fln' <- addTickHsExpr fln - return (Just fln') + addTickWit (Just fln) + = do fln' <- addTickSyntaxExpr hpcSrcSpan fln + return (Just fln') addTickHsExpr (ExplicitPArr ty es) = liftM2 ExplicitPArr (return ty) @@ -621,7 +622,7 @@ addTickHsExpr (ArithSeq ty wit arith_seq) = (addTickWit wit) (addTickArithSeqInfo arith_seq) where addTickWit Nothing = return Nothing - addTickWit (Just fl) = do fl' <- addTickHsExpr fl + addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl return (Just fl') -- We might encounter existing ticks (multiple Coverage passes) @@ -732,12 +733,13 @@ addTickStmt _isGuard (LastStmt e noret ret) = do (addTickLHsExpr e) (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) -addTickStmt _isGuard (BindStmt pat e bind fail) = do - liftM4 BindStmt +addTickStmt _isGuard (BindStmt pat e bind fail ty) = do + liftM5 BindStmt (addTickLPat pat) (addTickLHsExprRHS e) (addTickSyntaxExpr hpcSrcSpan bind) (addTickSyntaxExpr hpcSrcSpan fail) + (return ty) addTickStmt isGuard (BodyStmt e bind' guard' ty) = do liftM4 BodyStmt (addTick isGuard e) @@ -747,11 +749,12 @@ addTickStmt isGuard (BodyStmt e bind' guard' ty) = do addTickStmt _isGuard (LetStmt (L l binds)) = do liftM (LetStmt . L l) (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do - liftM3 ParStmt +addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do + liftM4 ParStmt (mapM (addTickStmtAndBinders isGuard) pairs) - (addTickSyntaxExpr hpcSrcSpan mzipExpr) + (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) (addTickSyntaxExpr hpcSrcSpan bindExpr) + (return ty) addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do args' <- mapM (addTickApplicativeArg isGuard) args return (ApplicativeStmt args' mb_join body_ty) @@ -765,7 +768,7 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts t_u <- addTickLHsExprRHS using t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr - t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr + L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr) return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } @@ -792,7 +795,7 @@ addTickApplicativeArg isGuard (op, arg) = addTickArg (ApplicativeArgMany stmts ret pat) = ApplicativeArgMany <$> addTickLStmts isGuard stmts - <*> addTickSyntaxExpr hpcSrcSpan ret + <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) <*> addTickLPat pat addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id @@ -837,9 +840,9 @@ addTickIPBind (IPBind nm e) = -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id) -addTickSyntaxExpr pos x = do +addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do L _ x' <- addTickLHsExpr (L pos x) - return $ x' + return $ syn { syn_expr = x' } -- we do not walk into patterns. addTickLPat :: LPat Id -> TM (LPat Id) addTickLPat pat = return pat @@ -951,12 +954,13 @@ addTickLCmdStmts' lstmts res binders = collectLStmtsBinders lstmts addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id)) -addTickCmdStmt (BindStmt pat c bind fail) = do - liftM4 BindStmt +addTickCmdStmt (BindStmt pat c bind fail ty) = do + liftM5 BindStmt (addTickLPat pat) (addTickLHsCmd c) (return bind) (return fail) + (return ty) addTickCmdStmt (LastStmt c noret ret) = do liftM3 LastStmt (addTickLHsCmd c) |