Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
-
9bc44eb4
by Apoorv Ingle at 2025-07-21T10:43:26-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
|
| ... | ... | @@ -75,7 +75,7 @@ expand_do_stmts _ (stmt@(L _ (XStmtLR ApplicativeStmt{})): _) = |
| 75 | 75 | |
| 76 | 76 | expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
|
| 77 | 77 | |
| 78 | -expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))]
|
|
| 78 | +expand_do_stmts flav [L sloc stmt@(LastStmt _ body@(L body_loc _) _ ret_expr)]
|
|
| 79 | 79 | -- See Note [Expanding HsDo with XXExprGhcRn] Equation (5) below
|
| 80 | 80 | -- last statement of a list comprehension, needs to explicitly return it
|
| 81 | 81 | -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
|
| ... | ... | @@ -90,7 +90,7 @@ expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))] |
| 90 | 90 | = do let expansion = L body_loc (genHsApp ret body)
|
| 91 | 91 | return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField expansion))
|
| 92 | 92 | |
| 93 | -expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
|
|
| 93 | +expand_do_stmts doFlavour (L loc stmt@(LetStmt _ bs) : lstmts) =
|
|
| 94 | 94 | -- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
|
| 95 | 95 | -- stmts ~~> stmts'
|
| 96 | 96 | -- ------------------------------------------------
|
| ... | ... | @@ -99,7 +99,7 @@ expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) = |
| 99 | 99 | let expansion = genHsLet bs (genPopErrCtxtExpr expand_stmts_expr)
|
| 100 | 100 | return $ L loc (mkExpandedStmt stmt doFlavour expansion)
|
| 101 | 101 | |
| 102 | -expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
|
|
| 102 | +expand_do_stmts doFlavour (L loc stmt@(BindStmt xbsrn pat e) : lstmts)
|
|
| 103 | 103 | | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
|
| 104 | 104 | , fail_op <- xbsrn_failOp xbsrn
|
| 105 | 105 | -- See Note [Expanding HsDo with XXExprGhcRn] Equation (2) below
|
| ... | ... | @@ -117,7 +117,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) |
| 117 | 117 | | otherwise
|
| 118 | 118 | = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
|
| 119 | 119 | |
| 120 | -expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
|
|
| 120 | +expand_do_stmts doFlavour (L loc stmt@(BodyStmt _ e (SyntaxExprRn then_op) _) : lstmts) =
|
|
| 121 | 121 | -- See Note [BodyStmt] in Language.Haskell.Syntax.Expr
|
| 122 | 122 | -- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below
|
| 123 | 123 | -- stmts ~~> stmts'
|
| ... | ... | @@ -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) |