Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
-
11b5f135
by Apoorv Ingle at 2025-07-21T10:16:02-05:00
4 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/Do.hs
Changes:
| ... | ... | @@ -674,11 +674,11 @@ type instance XXExpr GhcTc = XXExprGhcTc |
| 674 | 674 | -- See Note [Handling overloaded and rebindable constructs] in `GHC.Rename.Expr`
|
| 675 | 675 | data SrcCodeOrigin
|
| 676 | 676 | = OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression
|
| 677 | - | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from
|
|
| 678 | - | OrigPat (LPat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints
|
|
| 677 | + | OrigStmt (ExprStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from
|
|
| 678 | + | OrigPat (Pat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints
|
|
| 679 | 679 | |
| 680 | 680 | data XXExprGhcRn
|
| 681 | - = ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- The original source thing to be used for error messages
|
|
| 681 | + = ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- The original source thing to be used for error messages
|
|
| 682 | 682 | , xrn_expanded :: HsExpr GhcRn -- The compiler generated expanded thing
|
| 683 | 683 | }
|
| 684 | 684 | |
| ... | ... | @@ -706,7 +706,7 @@ mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigExpr oExpr |
| 706 | 706 | -- and the two components of the expansion: original do stmt and
|
| 707 | 707 | -- expanded expression
|
| 708 | 708 | mkExpandedStmt
|
| 709 | - :: ExprLStmt GhcRn -- ^ source statement
|
|
| 709 | + :: ExprStmt GhcRn -- ^ source statement
|
|
| 710 | 710 | -> HsDoFlavour -- ^ source statement do flavour
|
| 711 | 711 | -> HsExpr GhcRn -- ^ expanded expression
|
| 712 | 712 | -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
|
| ... | ... | @@ -659,23 +659,26 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts)) |
| 659 | 659 | _ -> Nothing
|
| 660 | 660 | |
| 661 | 661 | addTickHsExpanded :: SrcCodeOrigin -> HsExpr GhcTc -> TM (HsExpr GhcTc)
|
| 662 | -addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of
|
|
| 663 | - -- We always want statements to get a tick, so we can step over each one.
|
|
| 664 | - -- To avoid duplicates we blacklist SrcSpans we already inserted here.
|
|
| 665 | - OrigStmt (L pos _) _ -> do_tick_black pos
|
|
| 666 | - _ -> skip
|
|
| 667 | - where
|
|
| 668 | - skip = addTickHsExpr e
|
|
| 669 | - do_tick_black pos = do
|
|
| 670 | - d <- getDensity
|
|
| 671 | - case d of
|
|
| 672 | - TickForCoverage -> tick_it_black pos
|
|
| 673 | - TickForBreakPoints -> tick_it_black pos
|
|
| 674 | - _ -> skip
|
|
| 675 | - tick_it_black pos =
|
|
| 676 | - unLoc <$> allocTickBox (ExpBox False) False False (locA pos)
|
|
| 677 | - (withBlackListed (locA pos) $
|
|
| 678 | - addTickHsExpr e)
|
|
| 662 | +addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ addTickHsExpr e
|
|
| 663 | + |
|
| 664 | + |
|
| 665 | + -- case o of
|
|
| 666 | + -- -- We always want statements to get a tick, so we can step over each one.
|
|
| 667 | + -- -- To avoid duplicates we blacklist SrcSpans we already inserted here.
|
|
| 668 | + -- OrigStmt (L pos _) _ -> do_tick_black pos
|
|
| 669 | + -- _ -> skip
|
|
| 670 | + -- where
|
|
| 671 | + -- skip = addTickHsExpr e
|
|
| 672 | + -- do_tick_black pos = do
|
|
| 673 | + -- d <- getDensity
|
|
| 674 | + -- case d of
|
|
| 675 | + -- TickForCoverage -> tick_it_black pos
|
|
| 676 | + -- TickForBreakPoints -> tick_it_black pos
|
|
| 677 | + -- _ -> skip
|
|
| 678 | + -- tick_it_black pos =
|
|
| 679 | + -- unLoc <$> allocTickBox (ExpBox False) False False (locA pos)
|
|
| 680 | + -- (withBlackListed (locA pos) $
|
|
| 681 | + -- addTickHsExpr e)
|
|
| 679 | 682 | |
| 680 | 683 | addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
|
| 681 | 684 | addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e
|
| ... | ... | @@ -7239,7 +7239,7 @@ pprTyConInstFlavour |
| 7239 | 7239 | pprErrCtxtMsg :: ErrCtxtMsg -> SDoc
|
| 7240 | 7240 | pprErrCtxtMsg = \case
|
| 7241 | 7241 | ExprCtxt expr
|
| 7242 | - | XExpr (ExpandedThingRn (OrigStmt (L _ stmt) flav) _) <- expr
|
|
| 7242 | + | XExpr (ExpandedThingRn (OrigStmt stmt flav) _) <- expr
|
|
| 7243 | 7243 | -> hang (text "In a stmt of" <+> pprAStmtContext @(LIdP GhcRn) (HsDoStmt flav) <> colon)
|
| 7244 | 7244 | 2 (ppr_stmt stmt)
|
| 7245 | 7245 | | otherwise
|
| ... | ... | @@ -214,7 +214,7 @@ mk_fail_block doFlav pat e (Just (SyntaxExprRn fail_op)) = |
| 214 | 214 | |
| 215 | 215 | fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
|
| 216 | 216 | fail_op_expr dflags pat fail_op
|
| 217 | - = mkExpandedPatRn pat $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
|
|
| 217 | + = mkExpandedPatRn (unLoc pat) $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
|
|
| 218 | 218 | |
| 219 | 219 | mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
|
| 220 | 220 | mk_fail_msg_expr dflags pat
|
| ... | ... | @@ -489,5 +489,5 @@ mkPopErrCtxtExpr a = XExpr (PopErrCtxt a) |
| 489 | 489 | genPopErrCtxtExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
|
| 490 | 490 | genPopErrCtxtExpr (L loc a) = L loc (mkPopErrCtxtExpr a)
|
| 491 | 491 | |
| 492 | -mkExpandedPatRn :: LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
|
|
| 492 | +mkExpandedPatRn :: Pat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
|
|
| 493 | 493 | mkExpandedPatRn pat e = XExpr (ExpandedThingRn (OrigPat pat) e) |