Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: f6b42024 by Apoorv Ingle at 2025-08-11T11:02:36-05:00 notes and misc changes - - - - - 90a013ab by Apoorv Ingle at 2025-08-11T11:25:12-05:00 rename ea_ctxt -> ea_loc_span eaql_ctx -> eaql_loc_span - - - - - 7 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -675,11 +675,11 @@ type instance XXExpr GhcTc = XXExprGhcTc data SrcCodeOrigin = OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from - | OrigPat (Pat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints + | OrigPat (Pat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints data XXExprGhcRn - = ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- The original source thing to be used for error messages - , xrn_expanded :: HsExpr GhcRn -- The compiler generated expanded thing + = ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- The original source thing to be used for error messages + , xrn_expanded :: HsExpr GhcRn -- The compiler generated, expanded thing } | PopErrCtxt -- A hint for typechecker to pop ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -544,17 +544,18 @@ tcValArgs do_ql fun args = go do_ql 0 args go do_ql pos (arg : args) = do { arg' <- tcValArg do_ql pos' fun arg ; args' <- go do_ql pos' args - ; return (arg' : args') - } + ; return (arg' : args') } where -- increment position if the argument is user written type or value argument pos' | EValArg{} <- arg = pos + 1 | EValArgQL{} <- arg = pos + 1 - | ETypeArg{ ea_ctxt = l } <- arg - , not (isGeneratedSrcSpan l) = pos + 1 - | otherwise = pos + | ETypeArg{ ea_loc_span = l } <- arg + , not (isGeneratedSrcSpan l) + = pos + 1 + | otherwise + = pos tcValArg :: QLFlag -> Int -> HsExpr GhcRn -> HsExprArg 'TcpInst -- Actual argument @@ -566,7 +567,7 @@ tcValArg do_ql _ _ (EWrap (EHsWrap w)) = do { whenQL do_ql $ qlMonoHsWrapper w -- qlMonoHsWrapper: see Note [Monomorphise instantiation variables] tcValArg _ _ _ (EWrap ew) = return (EWrap ew) -tcValArg do_ql pos fun (EValArg { ea_ctxt = ctxt +tcValArg do_ql pos fun (EValArg { ea_loc_span = ctxt , ea_arg = larg@(L arg_loc arg) , ea_arg_ty = sc_arg_ty }) = addArgCtxt pos fun larg $ @@ -594,20 +595,21 @@ tcValArg do_ql pos fun (EValArg { ea_ctxt = ctxt tcPolyExpr arg (mkCheckExpType exp_arg_ty) ; traceTc "tcValArg" $ vcat [ ppr arg' , text "}" ] - ; return (EValArg { ea_ctxt = ctxt + ; return (EValArg { ea_loc_span = ctxt , ea_arg = L arg_loc arg' , ea_arg_ty = noExtField }) } -tcValArg _ pos fun (EValArgQL { eaql_wanted = wanted - , eaql_ctxt = ctxt - , eaql_arg_ty = sc_arg_ty - , eaql_larg = larg@(L arg_loc rn_expr) - , eaql_tc_fun = tc_head - , eaql_rn_fun = rn_fun - , eaql_fun_ue = head_ue - , eaql_args = inst_args - , eaql_encl = arg_influences_enclosing_call - , eaql_res_rho = app_res_rho }) +tcValArg _ pos fun (EValArgQL { + eaql_wanted = wanted + , eaql_loc_span = ctxt + , eaql_arg_ty = sc_arg_ty + , eaql_larg = larg@(L arg_loc rn_expr) + , eaql_tc_fun = tc_head + , eaql_rn_fun = rn_fun + , eaql_fun_ue = head_ue + , eaql_args = inst_args + , eaql_encl = arg_influences_enclosing_call + , eaql_res_rho = app_res_rho }) = addArgCtxt pos fun larg $ do { -- Expose QL results to tcSkolemise, as in EValArg case Scaled mult exp_arg_ty <- liftZonkM $ zonkScaledTcType sc_arg_ty @@ -644,7 +646,7 @@ tcValArg _ pos fun (EValArgQL { eaql_wanted = wanted ; traceTc "tcEValArgQL }" $ vcat [ text "app_res_rho:" <+> ppr app_res_rho ] - ; return (EValArg { ea_ctxt = ctxt + ; return (EValArg { ea_loc_span = ctxt , ea_arg = L arg_loc (mkHsWrap wrap arg') , ea_arg_ty = noExtField }) } @@ -814,10 +816,10 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args = go1 pos (EPrag sp prag : acc) fun_ty args -- Rule ITYARG from Fig 4 of the QL paper - go1 pos acc fun_ty ( ETypeArg { ea_ctxt = ctxt, ea_hs_ty = hs_ty } + go1 pos acc fun_ty ( ETypeArg { ea_loc_span = ctxt, ea_hs_ty = hs_ty } : rest_args ) = do { (ty_arg, inst_ty) <- tcVTA fun_conc_tvs fun_ty hs_ty - ; let arg' = ETypeArg { ea_ctxt = ctxt, ea_hs_ty = hs_ty, ea_ty_arg = ty_arg } + ; let arg' = ETypeArg { ea_loc_span = ctxt, ea_hs_ty = hs_ty, ea_ty_arg = ty_arg } ; go pos (arg' : acc) inst_ty rest_args } -- Rule IVAR from Fig 4 of the QL paper: @@ -857,7 +859,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args -- Rule IARG from Fig 4 of the QL paper: go1 pos acc fun_ty - (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args) + (EValArg { ea_arg = arg, ea_loc_span = ctxt } : rest_args) = do { let herald = mk_herald tc_fun (unLoc arg) ; (wrap, arg_ty, res_ty) <- -- NB: matchActualFunTy does the rep-poly check. @@ -924,9 +926,9 @@ addArgCtxt :: Int -> HsExpr GhcRn -> LHsExpr GhcRn -- There are 2 cases: -- 1. In the normal case, we add an informative context -- "In the third argument of f, namely blah" --- 2. If we are deep inside generated code (`isGeneratedCode` is `True`) +-- 2. If we are deep inside generated code (<=> `isGeneratedCode` is `True`) -- "In the expression: arg" --- If the arg is also a generated thing, i.e. arg_loc is generatedSrcSpan, we would print do nothing. +-- If the arg is also a generated thing, i.e. `arg_loc` is `generatedSrcSpan`, we would print nothing. -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr -- See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do addArgCtxt arg_no fun (L arg_loc arg) thing_inside @@ -1733,7 +1735,7 @@ quickLookArg DoQL pos ctxt fun larg orig_arg_ty skipQuickLook :: SrcSpan -> LHsExpr GhcRn -> Scaled TcRhoType -> TcM (HsExprArg 'TcpInst) skipQuickLook ctxt larg arg_ty - = return (EValArg { ea_ctxt = ctxt + = return (EValArg { ea_loc_span = ctxt , ea_arg = larg , ea_arg_ty = arg_ty }) @@ -1834,16 +1836,16 @@ quickLookArg1 pos ctxt fun larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) ; traceTc "quickLookArg done }" (ppr rn_fun) - ; return (EValArgQL { eaql_ctxt = ctxt - , eaql_arg_ty = sc_arg_ty - , eaql_larg = larg - , eaql_tc_fun = tc_head - , eaql_rn_fun = rn_fun - , eaql_fun_ue = fun_ue - , eaql_args = inst_args - , eaql_wanted = wanted - , eaql_encl = arg_influences_enclosing_call - , eaql_res_rho = app_res_rho }) }}} + ; return (EValArgQL { eaql_loc_span = ctxt + , eaql_arg_ty = sc_arg_ty + , eaql_larg = larg + , eaql_tc_fun = tc_head + , eaql_rn_fun = rn_fun + , eaql_fun_ue = fun_ue + , eaql_args = inst_args + , eaql_wanted = wanted + , eaql_encl = arg_influences_enclosing_call + , eaql_res_rho = app_res_rho }) }}} {- ********************************************************************* * * ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -75,7 +75,7 @@ expand_do_stmts _ (stmt@(L _ (XStmtLR ApplicativeStmt{})): _) = expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty -expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))] +expand_do_stmts _flav [_stmt@(L _sloc (LastStmt _ body@(L body_loc _) _ ret_expr))] -- See Note [Expanding HsDo with XXExprGhcRn] Equation (5) below -- last statement of a list comprehension, needs to explicitly return it -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt` @@ -83,7 +83,7 @@ expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))] -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt -- = return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField body)) = return body - | SyntaxExprRn ret <- ret_expr + | SyntaxExprRn ret <- ret_expr -- We have unfortunately lost the location on the return function :( -- -- ------------------------------------------------ -- return e ~~> return e @@ -230,7 +230,7 @@ mk_fail_block _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty {- Note [Expanding HsDo with XXExprGhcRn] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We expand `do`-blocks before typechecking it, by re-using the existing `XXExprGhcRns` and `RebindableSyntax` machinery. +We expand `do`-blocks before typechecking it, by re-using the existing `XXExprGhcRn` and `RebindableSyntax` machinery. This is very similar to: 1. Expansions done in `GHC.Rename.Expr.rnHsIf` for expanding `HsIf`; and 2. `desugarRecordUpd` in `GHC.Tc.Gen.Expr.tcExpr` for expanding `RecordUpd` @@ -275,14 +275,15 @@ They capture the essence of statement expansions as implemented in `expand_do_st DO【 _ 】 maps a sequence of do statements and recursively converts them into expressions - (1) DO【 s; ss 】 = ‹ExpansionStmt s›((>>) s (‹PopErrCtxt›DO【 ss 】)) + (1) DO【 s; ss 】 = ‹ExpansionStmt s›((>>) (‹PopErrCtxt› s) (‹PopErrCtxt› DO【 ss 】)) (2) DO【 p <- e; ss 】 = if p is irrefutable then ‹ExpansionStmt (p <- e)› - (>>=) s ((\ p -> ‹PopExprCtxt› DO【 ss 】)) + (>>=) (‹PopExprCtxt› s) ((\ p -> ‹PopExprCtxt› DO【 ss 】)) else ‹ExpansionStmt (p <- e)› - (>>=) s ((\case p -> ‹PopExprCtxt› DO【 ss 】 - _ -> fail "pattern p failure")) + (>>=) (‹PopExprCtxt› s) + (\case p -> ‹PopExprCtxt› DO【 ss 】 + _ -> fail "pattern p failure") (3) DO【 let x = e; ss 】 = ‹ExpansionStmt (let x = e)› (let x = e in (‹PopErrCtxt›DO【 ss 】)) @@ -313,8 +314,8 @@ The expanded version (performed by `expand_do_stmts`) looks like: {g2} (>>) ({l2} g p) ({l3} return p)) -The {l1} etc are location/source span information stored in the AST by the parser, -{g1} are compiler generated source spans. +The {l1}, {l2}, etc. are the location/source span information stored in the AST by the parser, +{g1}, {g2}, etc. are the compiler generated source spans. The 3 non-obvious points to consider are: @@ -427,10 +428,10 @@ It stores the original statement (with location) and the expanded expression ‹ExpandedThingRn do { e1; e2; e3 }› -- Original Do Expression -- Expanded Do Expression (‹ExpandedThingRn e1› -- Original Statement - ({(>>) e1} -- Expanded Expression - ‹PopErrCtxt› (‹ExpandedThingRn e2› - ({(>>) e2} - ‹PopErrCtxt› (‹ExpandedThingRn e3› {e3}))))) + ({(>>) ‹PopErrCtxt› e1} -- Expanded Expression + ‹PopErrCtxt› (‹ExpandedThingRn e2› + ({(>>) ‹PopErrCtxt› e2} + ‹PopErrCtxt› (‹ExpandedThingRn e3› {e3}))))) * Whenever the typechecker steps through an `ExpandedThingRn`, we push the original statement in the error context, set the error location to the @@ -445,7 +446,7 @@ It stores the original statement (with location) and the expanded expression as precise as possible, and not just blame the complete `do`-block. Thus, when we typecheck the application `(>>) e1`, we push the "In the stmt of do block e1" with the source location of `e1` in the error context stack as we walk inside an `ExpandedThingRn`. - See also Note [splitHsApps]. + See also Note [splitHsApps] and Note [Error Context Stack] * After the expanded expression of a `do`-statement is typechecked and before moving to the next statement of the `do`-block, we need to first pop the top ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -648,9 +648,9 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr res_ty = assert (notNull rbnds) $ do { -- Expand the record update. See Note [Record Updates]. - ; (ds_expr, ds_res_ty, err_ctxt) + ; (ds_expr, ds_res_ty, err_msg) <- expandRecordUpd record_expr possible_parents rbnds res_ty - ; addErrCtxt err_ctxt $ + ; addErrCtxt err_msg $ setInGeneratedCode (OrigExpr expr) $ do { -- Typecheck the expanded expression. expr' <- tcExpr ds_expr (Check ds_res_ty) @@ -748,9 +748,11 @@ tcXExpr (PopErrCtxt e) res_ty tcExpr e res_ty tcXExpr (ExpandedThingRn o e) res_ty - = mkExpandedTc o <$> -- necessary for breakpoints - do setInGeneratedCode o $ - tcExpr e res_ty + = setInGeneratedCode o $ + -- e is the expanded expression of o, so we need to set the error ctxt to generated + -- see Note [Error Context Stack] in `GHC.Tc.Type.LclEnv` + mkExpandedTc o <$> -- necessary for hpc ticks + tcExpr e res_ty -- For record selection, same as HsVar case tcXExpr xe res_ty = tcApp (XExpr xe) res_ty @@ -1441,7 +1443,7 @@ expandRecordUpd record_expr possible_parents rbnds res_ty -- STEP 2 (b): expand to HsCase, as per note [Record Updates] ; let ds_expr :: HsExpr GhcRn - ds_expr = HsLet noExtField let_binds (L gen case_expr) + ds_expr = HsLet noExtField let_binds (wrapGenSpan case_expr) case_expr :: HsExpr GhcRn case_expr = HsCase RecUpd record_expr @@ -1456,11 +1458,10 @@ expandRecordUpd record_expr possible_parents rbnds res_ty upd_ids_lhs = [ (NonRecursive, [genSimpleFunBind (idName id) [] rhs]) | (_, (id, rhs)) <- upd_ids ] mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn - mk_idSig (_, (id, _)) = L gen $ XSig $ IdSig id + mk_idSig (_, (id, _)) = wrapGenSpan (XSig $ IdSig id) -- We let-bind variables using 'IdSig' in order to accept -- record updates involving higher-rank types. -- See Wrinkle [Using IdSig] in Note [Record Updates]. - gen = noAnnSrcSpan generatedSrcSpan ; traceTc "expandRecordUpd" $ vcat [ text "relevant_con:" <+> ppr relevant_con ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -152,6 +152,7 @@ takes apart either an HsApp, or an infix OpApp, returning innermost un-expanded head as the "error head". * A list of HsExprArg, the arguments +* We do not look through expanded expressions (except PopErrCtxt.) -} data TcPass = TcpRn -- Arguments decomposed @@ -161,14 +162,14 @@ data TcPass = TcpRn -- Arguments decomposed data HsExprArg (p :: TcPass) where -- See Note [HsExprArg] -- Data constructor EValArg represents a value argument - EValArg :: { ea_ctxt :: SrcSpan + EValArg :: { ea_loc_span :: SrcSpan , ea_arg_ty :: !(XEVAType p) , ea_arg :: LHsExpr (GhcPass (XPass p)) } -> HsExprArg p -- Data constructor EValArgQL represents an argument that has been -- partly-type-checked by Quick Look; see Note [EValArgQL] - EValArgQL :: { eaql_ctxt :: SrcSpan + EValArgQL :: { eaql_loc_span :: SrcSpan , eaql_arg_ty :: Scaled TcSigmaType -- Argument type expected by function , eaql_larg :: LHsExpr GhcRn -- Original application, for -- location and error msgs @@ -182,7 +183,7 @@ data HsExprArg (p :: TcPass) where -- See Note [HsExprArg] , eaql_res_rho :: TcRhoType } -- Result type of the application -> HsExprArg 'TcpInst -- Only exists in TcpInst phase - ETypeArg :: { ea_ctxt :: SrcSpan + ETypeArg :: { ea_loc_span :: SrcSpan , ea_hs_ty :: LHsWcType GhcRn -- The type arg , ea_ty_arg :: !(XETAType p) } -- Kind-checked type arg -> HsExprArg p @@ -215,12 +216,12 @@ type family XPass (p :: TcPass) where XPass 'TcpTc = 'Typechecked mkEValArg :: SrcSpan -> LHsExpr GhcRn -> HsExprArg 'TcpRn -mkEValArg ctxt e = EValArg { ea_arg = e, ea_ctxt = ctxt +mkEValArg src_loc e = EValArg { ea_arg = e, ea_loc_span = src_loc , ea_arg_ty = noExtField } mkETypeArg :: SrcSpan -> LHsWcType GhcRn -> HsExprArg 'TcpRn -mkETypeArg ctxt hs_ty = - ETypeArg { ea_ctxt = ctxt +mkETypeArg src_loc hs_ty = + ETypeArg { ea_loc_span = src_loc , ea_hs_ty = hs_ty , ea_ty_arg = noExtField } @@ -291,9 +292,9 @@ rebuildHsApps :: (HsExpr GhcTc, SrcSpan) rebuildHsApps (fun, _) [] = fun rebuildHsApps (fun, sloc) (arg : args) = case arg of - EValArg { ea_arg = arg, ea_ctxt = sloc' } + EValArg { ea_arg = arg, ea_loc_span = sloc' } -> rebuildHsApps (HsApp noExtField lfun arg, sloc') args - ETypeArg { ea_hs_ty = hs_ty, ea_ty_arg = ty, ea_ctxt = sloc' } + ETypeArg { ea_hs_ty = hs_ty, ea_ty_arg = ty, ea_loc_span = sloc' } -> rebuildHsApps (HsAppType ty lfun hs_ty, sloc') args EPrag sloc' p -> rebuildHsApps (HsPragE noExtField p lfun, sloc') args @@ -330,7 +331,7 @@ instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where ppr (EPrag _ p) = text "EPrag" <+> ppr p ppr (ETypeArg { ea_hs_ty = hs_ty }) = char '@' <> ppr hs_ty ppr (EWrap wrap) = ppr wrap - ppr (EValArg { ea_arg = arg, ea_ctxt = sloc }) + ppr (EValArg { ea_arg = arg, ea_loc_span = sloc }) = text "EValArg" <> braces (ppr sloc) <+> ppr arg ppr (EValArgQL { eaql_tc_fun = fun, eaql_args = args, eaql_res_rho = ty}) = hang (text "EValArgQL" <+> ppr fun) ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -91,29 +91,54 @@ data TcLclEnv -- Changes as we move inside an expression tcl_errs :: TcRef (Messages TcRnMessage) -- Place to accumulate diagnostics } +{- +Note [Error Context Stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +This data structure keeps track of two things: +1. Are we type checking a compiler generated/non-user written code. +2. The trail of the error messages that have been added in route to the current expression + +* When the `ErrCtxtStack` is a `UserCodeCtxt`, + - the current expression being typechecked is user written +* When the `ErrorCtxtStack` is a `GeneratedCodeCtxt` + - the current expression being typechecked is compiler generated; + - the original, possibly user written, source code thing is stored in `src_code_origin` field. + - the `src_code_origin` is what will be blamed in the error message + +-} + +-- See Note [Error Context Stack] data ErrCtxtStack - = UserCodeCtxt {err_ctxt :: [ErrCtxt]} - | GeneratedCodeCtxt { src_code_origin :: SrcCodeOrigin - , err_ctxt :: [ErrCtxt] } + = UserCodeCtxt { lcl_err_ctxt :: [ErrCtxt] } -- ^ Trail of error messages + | GeneratedCodeCtxt { src_code_origin :: SrcCodeOrigin -- ^ Original, user written code + , lcl_err_ctxt :: [ErrCtxt] } -- ^ Trail of error messages +-- | Are we in a generated context? isGeneratedCodeCtxt :: ErrCtxtStack -> Bool isGeneratedCodeCtxt UserCodeCtxt{} = False isGeneratedCodeCtxt _ = True +-- | Get the original source code get_src_code_origin :: ErrCtxtStack -> Maybe SrcCodeOrigin get_src_code_origin (UserCodeCtxt{}) = Nothing + -- we are in user code, so blame the expression in hand get_src_code_origin es = Just $ src_code_origin es + -- we are in generated code, so extract the original expression +-- | Modify the error context stack +-- N.B. If we are in a generated context, any updates to the context stack are ignored. +-- We want to blame the errors that appear in a generated expression +-- to the original, user written code modify_err_ctxt_stack :: ([ErrCtxt] -> [ErrCtxt]) -> ErrCtxtStack -> ErrCtxtStack modify_err_ctxt_stack f (UserCodeCtxt e) = UserCodeCtxt (f e) -modify_err_ctxt_stack _ c = c -- any updates on the err context in generated context should be ignored +modify_err_ctxt_stack _ c = c -- any updates on the err context in a generated context should be ignored data TcLclCtxt = TcLclCtxt { tcl_loc :: RealSrcSpan, -- Source span - tcl_ctxt :: ErrCtxtStack, + tcl_ctxt :: ErrCtxtStack, -- See Note [Error Context Stack] tcl_tclvl :: TcLevel, tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, -- and for tidying type @@ -178,7 +203,7 @@ getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc . tcl_lcl_ctxt getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt] -getLclEnvErrCtxt = err_ctxt . tcl_ctxt . tcl_lcl_ctxt +getLclEnvErrCtxt = lcl_err_ctxt . tcl_ctxt . tcl_lcl_ctxt setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ _ -> ctxt) (tcl_ctxt env) }) @@ -193,7 +218,7 @@ setLclEnvSrcCodeOrigin :: SrcCodeOrigin -> TcLclEnv -> TcLclEnv setLclEnvSrcCodeOrigin o = modifyLclCtxt (setLclCtxtSrcCodeOrigin o) setLclCtxtSrcCodeOrigin :: SrcCodeOrigin -> TcLclCtxt -> TcLclCtxt -setLclCtxtSrcCodeOrigin o ctxt = ctxt { tcl_ctxt = GeneratedCodeCtxt o (err_ctxt $ tcl_ctxt ctxt) } +setLclCtxtSrcCodeOrigin o ctxt = ctxt { tcl_ctxt = GeneratedCodeCtxt o (lcl_err_ctxt $ tcl_ctxt ctxt) } lclCtxtInGeneratedCode :: TcLclCtxt -> Bool lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_ctxt ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -974,9 +974,9 @@ inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -- See Note [Error contexts in generated code] --- for the tcl_in_gen_code manipulation setSrcSpan (RealSrcSpan loc _) thing_inside - = updLclCtxt (\env -> env { tcl_loc = loc, tcl_ctxt = UserCodeCtxt (err_ctxt $ tcl_ctxt env)}) + = updLclCtxt (\env -> env { tcl_loc = loc + , tcl_ctxt = UserCodeCtxt (lcl_err_ctxt $ tcl_ctxt env)}) thing_inside setSrcSpan (UnhelpfulSpan _) thing_inside @@ -988,6 +988,7 @@ getSrcCodeOrigin = getLclEnvSrcCodeOrigin <$> getLclEnv -- | Mark the inner computation as being done inside generated code. -- -- See Note [Error contexts in generated code] +-- See Note [Error Context Stack] setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a setInGeneratedCode sco thing_inside = updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside @@ -1210,17 +1211,17 @@ problem. Note [Error contexts in generated code] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* setSrcSpan sets tcl_in_gen_code to True if the SrcSpan is GeneratedSrcSpan, - and back to False when we get a useful SrcSpan +* If the `SrcSpan` is a `RealSrcSpan`, `setSrcSpan` updates the `tcl_loc`, + and makes the `ErrCtxStack` a `UserCodeCtxt` +* it is a no-op otherwise -* When tcl_in_gen_code is True, addErrCtxt becomes a no-op. +So, it's better to do a `setSrcSpan` /before/ `addErrCtxt`. -So typically it's better to do setSrcSpan /before/ addErrCtxt. - -See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr for -more discussion of this fancy footwork, as well as -Note [Generated code and pattern-match checking] in GHC.Types.Basic for the -relation with pattern-match checks. +- See Note [Rebindable syntax and XXExprGhcRn] in `GHC.Hs.Expr` for +more discussion of this fancy footwork +- See Note [Generated code and pattern-match checking] in `GHC.Types.Basic` for the +relation with pattern-match checks +- See Note [Error Context Stack] in `GHC.Tc.Types.LclEnv` for info about `ErrCtxtStack` -} getErrCtxt :: TcM [ErrCtxt] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/35d5a38dc11ddbc6e4482d595de1875... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/35d5a38dc11ddbc6e4482d595de1875... You're receiving this email because of your account on gitlab.haskell.org.