Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC
Commits:
-
4800bc7c
by Apoorv Ingle at 2026-02-22T21:39:54-06:00
6 changed files:
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/TyCl/Instance.hs
Changes:
| ... | ... | @@ -620,48 +620,18 @@ deriving instance Eq (IE GhcTc) |
| 620 | 620 | |
| 621 | 621 | -- ---------------------------------------------------------------------
|
| 622 | 622 | |
| 623 | --- deriving instance Data ErrCtxtMsg
|
|
| 624 | --- deriving instance Data XXExprGhcRn
|
|
| 625 | -con_ExpandedThingRn = mkConstr xXExprGhcRn_T "ExpandedThingRn" [] Prefix
|
|
| 626 | -con_HsRecSelRn = mkConstr xXExprGhcRn_T "HsRecSelRn" [] Prefix
|
|
| 627 | -xXExprGhcRn_T = mkDataType "GHC.Hs.Expr.XXExprGhcRn" []
|
|
| 623 | +instance Data ErrCtxtMsg where
|
|
| 624 | + gunfold _ _ _ = error "no gunfold for ErrCtxtMsg"
|
|
| 625 | + gfoldl _ _ _ = error "no goldl for ErrCtxtMsg"
|
|
| 628 | 626 | |
| 629 | -instance Data XXExprGhcRn where
|
|
| 630 | - toConstr (ExpandedThingRn{}) = con_ExpandedThingRn
|
|
| 631 | - toConstr (HsRecSelRn{}) = con_HsRecSelRn
|
|
| 632 | 627 | |
| 633 | - dataTypeOf _ = xXExprGhcRn_T
|
|
| 634 | - |
|
| 635 | - gunfold k z c = error "no gunfold for XXExprGhcRn"
|
|
| 636 | - gfoldl k z c = error "no gfoldl for XXExprGhcRn"
|
|
| 628 | +deriving instance Data XXExprGhcRn
|
|
| 637 | 629 | |
| 638 | 630 | deriving instance Data a => Data (WithUserRdr a)
|
| 639 | 631 | |
| 640 | --- ---------------------------------------------------------------------
|
|
| 641 | - |
|
| 642 | --- deriving instance Data XXExprGhcTc
|
|
| 643 | -con_ExpandedThingTc = mkConstr xXExprGhcTc_T "ExpandedThingTc" [] Prefix
|
|
| 644 | -con_WrapExpr = mkConstr xXExprGhcTc_T "WrapExpr" [] Prefix
|
|
| 645 | -con_ConLikeTc = mkConstr xXExprGhcTc_T "ConLikeTc" [] Prefix
|
|
| 646 | -con_HsTick = mkConstr xXExprGhcTc_T "HsTick" [] Prefix
|
|
| 647 | -con_HsBinTick = mkConstr xXExprGhcTc_T "HsBinTick" [] Prefix
|
|
| 648 | -con_HsRecSelTc = mkConstr xXExprGhcTc_T "HsRecSelTc" [] Prefix
|
|
| 649 | -xXExprGhcTc_T = mkDataType "GHC.Hs.Expr.XXExprGhcTc" []
|
|
| 650 | - |
|
| 651 | -instance Data XXExprGhcTc where
|
|
| 652 | - toConstr (ExpandedThingTc{}) = con_ExpandedThingTc
|
|
| 653 | - toConstr (WrapExpr{}) = con_WrapExpr
|
|
| 654 | - toConstr (ConLikeTc{}) = con_ConLikeTc
|
|
| 655 | - toConstr (HsTick{}) = con_HsTick
|
|
| 656 | - toConstr (HsBinTick{}) = con_HsBinTick
|
|
| 657 | - toConstr (HsRecSelTc{}) = con_HsRecSelTc
|
|
| 658 | - |
|
| 659 | - dataTypeOf _ = xXExprGhcTc_T
|
|
| 660 | - |
|
| 661 | - |
|
| 662 | - gunfold _ _ _ = error "no gunfold for XXExprGhcTc"
|
|
| 663 | - gfoldl _ _ _ = error "no gfoldl for XXExprGhcTc"
|
|
| 664 | - |
|
| 632 | +-- -------------------------------
|
|
| 633 | +--------------------------------------
|
|
| 634 | +deriving instance Data XXExprGhcTc
|
|
| 665 | 635 | deriving instance Data XXPatGhcTc
|
| 666 | 636 | |
| 667 | 637 | -- ---------------------------------------------------------------------
|
| ... | ... | @@ -40,6 +40,7 @@ import GHC.Hs |
| 40 | 40 | -- needs to see source types
|
| 41 | 41 | import GHC.Tc.Utils.TcType
|
| 42 | 42 | import GHC.Tc.Types.Evidence
|
| 43 | +import GHC.Tc.Types.ErrCtxt
|
|
| 43 | 44 | import GHC.Tc.Utils.Monad
|
| 44 | 45 | import GHC.Tc.Instance.Class (lookupHasFieldLabel)
|
| 45 | 46 | |
| ... | ... | @@ -296,7 +297,7 @@ dsExpr e@(XExpr ext_expr_tc) |
| 296 | 297 | ConLikeTc {} -> dsApp e
|
| 297 | 298 | |
| 298 | 299 | ExpandedThingTc o e
|
| 299 | - | OrigStmt (L loc _) _ <- o -- c.f. T14546d. We have lost the location of the first statement in the GhcRn -> GhcTc
|
|
| 300 | + | DoStmtErrCtxt _ (L loc _) <- o -- c.f. T14546d. We have lost the location of the first statement in the GhcRn -> GhcTc
|
|
| 300 | 301 | -> putSrcSpanDsA loc $ dsExpr e
|
| 301 | 302 | | otherwise -> dsExpr e
|
| 302 | 303 |
| ... | ... | @@ -41,6 +41,7 @@ import GHC.Hs.Decls.Overlap ( OverlapMode(..) ) |
| 41 | 41 | |
| 42 | 42 | import GHC.Tc.Utils.TcType
|
| 43 | 43 | import GHC.Tc.Types.Evidence
|
| 44 | +import GHC.Tc.Types.ErrCtxt
|
|
| 44 | 45 | import GHC.Tc.TyCl ( IsPrefixConGADT(..), unannotatedMultIsLinear )
|
| 45 | 46 | |
| 46 | 47 | import GHC.Core.Class
|
| ... | ... | @@ -1732,7 +1733,7 @@ repE (HsFunArr _ mult arg res) = do |
| 1732 | 1733 | res' <- repLE res
|
| 1733 | 1734 | repApps fun [arg', res']
|
| 1734 | 1735 | repE e@(XExpr (ExpandedThingRn o x))
|
| 1735 | - | OrigExpr e <- o
|
|
| 1736 | + | ExprCtxt e <- o
|
|
| 1736 | 1737 | = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
|
| 1737 | 1738 | ; if rebindable_on -- See Note [Quotation and rebindable syntax]
|
| 1738 | 1739 | then repE x
|
| ... | ... | @@ -268,6 +268,13 @@ tcCheckMonoExpr, tcCheckMonoExprNC |
| 268 | 268 | tcCheckMonoExpr expr res_ty = tcMonoLExpr expr (mkCheckExpType res_ty)
|
| 269 | 269 | tcCheckMonoExprNC expr res_ty = tcMonoLExprNC expr (mkCheckExpType res_ty)
|
| 270 | 270 | |
| 271 | + |
|
| 272 | +-- Expand the HsExpr if it is typechecked after expansions
|
|
| 273 | +-- See Note [Handling overloaded and rebindable constructs]
|
|
| 274 | +-- See Note [Typechecking by expansion: overview]
|
|
| 275 | +expand_expr :: HsExpr GhcRn -> TcM (HsExpr GhcRn)
|
|
| 276 | +expand_expr x = return x
|
|
| 277 | + |
|
| 271 | 278 | ---------------
|
| 272 | 279 | tcMonoLExpr, tcMonoLExprNC
|
| 273 | 280 | :: LHsExpr GhcRn -- Expression to type check
|
| ... | ... | @@ -276,9 +283,10 @@ tcMonoLExpr, tcMonoLExprNC |
| 276 | 283 | -> TcM (LHsExpr GhcTc)
|
| 277 | 284 | |
| 278 | 285 | tcMonoLExpr (L loc expr) res_ty
|
| 279 | - = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code]
|
|
| 280 | - do { expr' <- tcExpr expr res_ty
|
|
| 281 | - ; return (L loc expr') }
|
|
| 286 | + = do expanded_expr <- expand_expr expr
|
|
| 287 | + addLExprCtxt (locA loc) expanded_expr $ -- Note [Error contexts in generated code]
|
|
| 288 | + do { expr' <- tcExpr expr res_ty
|
|
| 289 | + ; return (L loc expr') }
|
|
| 282 | 290 | |
| 283 | 291 | tcMonoLExprNC (L loc expr) res_ty
|
| 284 | 292 | = setSrcSpanA loc $
|
| ... | ... | @@ -676,7 +684,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr |
| 676 | 684 | |
| 677 | 685 | ; (ds_expr, ds_res_ty, err_msg)
|
| 678 | 686 | <- expandRecordUpd record_expr possible_parents rbnds res_ty
|
| 679 | - ; addExpansionErrCtxt (ExprCtxt expr) err_msg $
|
|
| 687 | + ; addExpansionErrCtxt err_msg $
|
|
| 680 | 688 | do { -- Typecheck the expanded expression.
|
| 681 | 689 | expr' <- tcExpr ds_expr (Check ds_res_ty)
|
| 682 | 690 | -- NB: it's important to use ds_res_ty and not res_ty here.
|
| ... | ... | @@ -487,7 +487,7 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside |
| 487 | 487 | | otherwise
|
| 488 | 488 | = do { (stmt', (stmts', thing)) <-
|
| 489 | 489 | setSrcSpanA loc $
|
| 490 | - addErrCtxt (StmtErrCtxt ctxt (L loc stmt)) $
|
|
| 490 | + addErrCtxt (StmtErrCtxt ctxt stmt) $
|
|
| 491 | 491 | stmt_chk ctxt stmt res_ty $ \ res_ty' ->
|
| 492 | 492 | popErrCtxt $
|
| 493 | 493 | tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
|
| ... | ... | @@ -2108,7 +2108,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind |
| 2108 | 2108 | -- The instance-sig is the focus here; the class-meth-sig
|
| 2109 | 2109 | -- is fixed (#18036)
|
| 2110 | 2110 | ; let orig = InstanceSigOrigin sel_name sig_ty local_meth_ty
|
| 2111 | - ; hs_wrap <- addErrCtxtM (MethSigCtxt sel_name sig_ty meth_ty) $
|
|
| 2111 | + ; hs_wrap <- addErrCtxtM (MethSigCtxt sel_name sig_ty local_meth_ty) $
|
|
| 2112 | 2112 | tcSubTypeSigma orig ctxt sig_ty local_meth_ty
|
| 2113 | 2113 | ; return (sig_ty, hs_wrap) }
|
| 2114 | 2114 |