Apoorv Ingle pushed to branch wip/ani/kill-popErrCtxt at Glasgow Haskell Compiler / GHC Commits: cce16183 by Apoorv Ingle at 2025-10-15T16:30:04+08:00 remote tcl_in_gen_code - - - - - cb15fefa by Apoorv Ingle at 2025-10-20T18:54:06+08:00 kill popErrCtxt - - - - - 11 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Quote.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/Gen/Match.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -676,22 +676,21 @@ 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 + | PopErrCtxt -- A hint for typechecker to pop + -- the top of the error context stack + -- Does not presist post renaming phase + -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn] + -- in `GHC.Tc.Gen.Do` 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 } - | PopErrCtxt -- A hint for typechecker to pop - {-# UNPACK #-} !(HsExpr GhcRn) -- the top of the error context stack - -- Does not presist post renaming phase - -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn] - -- in `GHC.Tc.Gen.Do` | HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector -- See Note [Non-overloaded record field selectors] and -- Note [Record selectors in the AST] - -- | Build an expression using the extension constructor `XExpr`, -- and the two components of the expansion: original expression and -- expanded expressions. @@ -713,6 +712,12 @@ mkExpandedStmt mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigStmt oStmt flav , xrn_expanded = eExpr }) +mkExpandedLastStmt + :: HsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedLastStmt eExpr = XExpr (ExpandedThingRn { xrn_orig = PopErrCtxt + , xrn_expanded = eExpr }) + data XXExprGhcTc = WrapExpr -- Type and evidence application and abstractions HsWrapper (HsExpr GhcTc) @@ -1083,11 +1088,11 @@ instance Outputable SrcCodeOrigin where OrigExpr x -> ppr_builder "<OrigExpr>:" x OrigStmt x _ -> ppr_builder "<OrigStmt>:" x OrigPat x -> ppr_builder "<OrigPat>:" x + PopErrCtxt -> text "<PopErrCtxt>" where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x) instance Outputable XXExprGhcRn where ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, text ";;" , ppr e]) (ppr o) - ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e) ppr (HsRecSelRn f) = pprPrefixOcc f instance Outputable XXExprGhcTc where @@ -1133,7 +1138,6 @@ ppr_infix_expr _ = Nothing ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing -ppr_infix_expr_rn (PopErrCtxt a) = ppr_infix_expr a ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f) ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc @@ -1233,7 +1237,6 @@ hsExprNeedsParens prec = go go_x_rn :: XXExprGhcRn -> Bool go_x_rn (ExpandedThingRn thing _ ) = hsExpandedNeedsParens thing - go_x_rn (PopErrCtxt a) = hsExprNeedsParens prec a go_x_rn (HsRecSelRn{}) = False hsExpandedNeedsParens :: SrcCodeOrigin -> Bool @@ -1286,7 +1289,6 @@ isAtomicHsExpr (XExpr x) go_x_rn :: XXExprGhcRn -> Bool go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing - go_x_rn (PopErrCtxt a) = isAtomicHsExpr a go_x_rn (HsRecSelRn{}) = True isAtomicExpandedThingRn :: SrcCodeOrigin -> Bool ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1747,7 +1747,6 @@ repE e@(XExpr (ExpandedThingRn o x)) else repE e } | otherwise = notHandled (ThExpressionForm e) -repE (XExpr (PopErrCtxt e)) = repE e repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (mkHsVar (noLocA x)) repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e) repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e) ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -951,10 +951,10 @@ addArgCtxt arg_no fun (L arg_loc arg) thing_inside , text "arg: " <+> ppr (arg, arg_no) , text "arg_loc:" <+> ppr arg_loc , text "fun:" <+> ppr fun - , text "err_ctx" <+> vcat (fmap (\ (x, y) -> case x of - UserCodeCtxt{} -> text "<USER>" <+> pprErrCtxtMsg y - ExpansionCodeCtxt{} -> text "<EXPN>" <+> pprErrCtxtMsg y) - (take 4 (zip err_ctx err_ctx_msg))) + -- , text "err_ctx" <+> vcat (fmap (\ (x, y) -> case x of + -- UserCodeCtxt{} -> text "<USER>" <+> pprErrCtxtMsg y + -- ExpansionCodeCtxt{} -> text "<EXPN>" <+> pprErrCtxtMsg y) + -- (take 4 (zip err_ctx err_ctx_msg))) ]) ; if in_generated_code then updCtxtForArg (locA arg_loc) arg $ @@ -968,10 +968,10 @@ addArgCtxt arg_no fun (L arg_loc arg) thing_inside do setSrcSpan l $ addExprCtxt e $ thing_inside - updCtxtForArg (UnhelpfulSpan UnhelpfulGenerated) _ thing_inside = -- See 2.i above - thing_inside + -- updCtxtForArg (UnhelpfulSpan UnhelpfulGenerated) _ thing_inside = -- See 2.i above + -- thing_inside updCtxtForArg (UnhelpfulSpan {}) _ thing_inside = -- See 2.ii above - do setInUserCode $ + do -- setInUserCode $ thing_inside ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -81,7 +81,7 @@ expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))] -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt` | NoSyntaxExprRn <- 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 $ L sloc (mkExpandedLastStmt (HsPar noExtField body)) | SyntaxExprRn ret <- ret_expr -- We have unfortunately lost the location on the return function :( -- @@ -89,7 +89,7 @@ expand_do_stmts flav [stmt@(L sloc (LastStmt _ body@(L body_loc _) _ ret_expr))] -- return e ~~> return e -- to make T18324 work = do let expansion = L body_loc (genHsApp ret body) - return $ L sloc (mkExpandedStmt stmt flav (HsPar noExtField expansion)) + return $ L sloc (mkExpandedLastStmt (HsPar noExtField expansion)) expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) = -- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below @@ -126,7 +126,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) -- e ; stmts ~~> (>>) e stmts' do expand_stmts_expr <- expand_do_stmts doFlavour lstmts let expansion = genHsExpApps then_op -- (>>) - [ wrapNoSpan $ unLoc e -- Span is set because of statement loc + [ e -- Span is set because of statement loc , expand_stmts_expr ] return $ L loc (mkExpandedStmt stmt doFlavour expansion) ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -54,6 +54,7 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep import GHC.Tc.Utils.Instantiate import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt ( srcCodeOriginErrCtxMsg ) import GHC.Tc.Types.Evidence import GHC.Tc.Errors.Types hiding (HoleError) @@ -665,9 +666,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr ; (ds_expr, ds_res_ty, err_msg) <- expandRecordUpd record_expr possible_parents rbnds res_ty - ; addErrCtxt err_msg $ - updLclCtxt setLclCtxtInGenCode $ - -- setInGeneratedCode (OrigExpr expr) $ + ; addExpansionErrCtxt (OrigExpr expr) err_msg $ do { -- Typecheck the expanded expression. expr' <- tcExpr ds_expr (Check ds_res_ty) -- NB: it's important to use ds_res_ty and not res_ty here. @@ -722,7 +721,7 @@ tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not -- Here we get rid of it and add the finalizers to the global environment. -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. tcExpr (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty -tcExpr e@(HsTypedBracket _ext body) res_ty = tcTypedBracket e body res_ty +tcExpr e@(HsTypedBracket _ext body) res_ty = tcTypedBracket e body res_ty tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty tcExpr (HsUntypedSplice splice _) res_ty @@ -757,14 +756,8 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) -} tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - -tcXExpr (PopErrCtxt e) res_ty - = do popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` - addExprCtxt e $ - tcExpr e res_ty - tcXExpr (ExpandedThingRn o e) res_ty - = setInGeneratedCode o $ + = addExpansionErrCtxt o (srcCodeOriginErrCtxMsg 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 ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -49,6 +49,7 @@ import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt ( srcCodeOriginErrCtxMsg ) import GHC.Tc.Types.Constraint( WantedConstraints ) import GHC.Tc.Utils.TcType as TcType import GHC.Tc.Types.Evidence @@ -269,7 +270,6 @@ splitHsApps e = go e noSrcSpan [] -- and its hard to say exactly what that is : EWrap (EExpand e) : args ) - go (XExpr (PopErrCtxt fun)) lspan args = go fun lspan args -- look through PopErrCtxt (cf. T17594f) we do not want to lose the opportunity of calling tcEValArgQL -- unlike HsPar, it is okay to forget about the PopErrCtxts as it does not persist over in GhcTc land @@ -471,9 +471,8 @@ tcInferAppHead_maybe fun = case fun of HsVar _ nm -> Just <$> tcInferId nm XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f - XExpr (ExpandedThingRn o e) -> Just <$> (setInGeneratedCode o $ -- We do not want to instantiate c.f. T19167 - tcExprSigma False e) - XExpr (PopErrCtxt e) -> tcInferAppHead_maybe e + XExpr (ExpandedThingRn o e) -> Just <$> (addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $ -- We do not want to instantiate c.f. T19167 + tcExprSigma False e) ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty HsOverLit _ lit -> Just <$> tcInferOverLit lit _ -> return Nothing ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -57,6 +57,7 @@ import GHC.Tc.Gen.Bind import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt ( srcCodeOriginErrCtxMsg ) import GHC.Tc.Types.Evidence import GHC.Rename.Env ( irrefutableConLikeTc ) @@ -404,9 +405,9 @@ tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty ; return (HsDo res_ty doExpr (L l stmts')) } else do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly ; let orig = HsDo noExtField doExpr ss - ; setInGeneratedCode (OrigExpr orig) $ do - { e' <- tcMonoLExpr expanded_expr res_ty - ; return (mkExpandedExprTc orig (unLoc e'))} + ; addExpansionErrCtxt (OrigExpr orig) (srcCodeOriginErrCtxMsg (OrigExpr orig)) $ + do { e' <- tcMonoLExpr expanded_expr res_ty + ; return (mkExpandedExprTc orig (unLoc e'))} } } ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -4,7 +4,7 @@ {-# LANGUAGE UndecidableInstances #-} module GHC.Tc.Types.ErrCtxt - ( ErrCtxt (..), ErrCtxtMsg(..), srcCodeOriginErrCtxMsg + ( ErrCtxt (..), ErrCtxtMsg(..), ErrCtxtMsgM, CodeSrcFlag (..), srcCodeOriginErrCtxMsg , UserSigType(..), FunAppCtxtFunArg(..) , TyConInstFlavour(..) ) @@ -48,9 +48,11 @@ import qualified Data.List.NonEmpty as NE -------------------------------------------------------------------------------- +type ErrCtxtMsgM = TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) + -- | Additional context to include in an error message, e.g. -- "In the type signature ...", "In the ambiguity check for ...", etc. -data ErrCtxt = UserCodeCtxt (Bool, TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) +data ErrCtxt = MkErrCtxt CodeSrcFlag ErrCtxtMsgM -- Monadic so that we have a chance -- to deal with bound type variables just before error -- message construction @@ -58,11 +60,9 @@ data ErrCtxt = UserCodeCtxt (Bool, TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -- Bool: True <=> this is a landmark context; do not -- discard it when trimming for display - | ExpansionCodeCtxt SrcCodeOrigin - -- The payload is a SrcCodeOrigin because it is used to generate - -- 1. The CtOrigin for CtLoc, and - -- 2. ErrCtxtMsg in error messages - +data CodeSrcFlag = VanillaUserSrcCode + | LandmarkUserSrcCode + | ExpansionCodeCtxt SrcCodeOrigin -------------------------------------------------------------------------------- -- Error message contexts @@ -233,3 +233,4 @@ srcCodeOriginErrCtxMsg :: SrcCodeOrigin -> ErrCtxtMsg srcCodeOriginErrCtxMsg (OrigExpr e) = ExprCtxt e srcCodeOriginErrCtxMsg (OrigStmt s f) = StmtErrCtxt (HsDoStmt f) (unLoc s) srcCodeOriginErrCtxMsg (OrigPat p) = PatCtxt p +srcCodeOriginErrCtxMsg (PopErrCtxt) = error "Shouldn't happen srcCodeOriginErr" ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -25,8 +25,6 @@ module GHC.Tc.Types.LclEnv ( , setLclEnvSrcCodeOrigin , setLclCtxtSrcCodeOrigin , lclEnvInGeneratedCode - , setLclCtxtInGenCode - , setLclCtxtInUserCode , addLclEnvErrCtxt @@ -38,7 +36,7 @@ module GHC.Tc.Types.LclEnv ( import GHC.Prelude -import GHC.Hs ( SrcCodeOrigin ) +import GHC.Hs ( SrcCodeOrigin (..) ) import GHC.Tc.Utils.TcType ( TcLevel ) import GHC.Tc.Errors.Types ( TcRnMessage ) @@ -119,7 +117,7 @@ type ErrCtxtStack = [ErrCtxt] -- | Get the original source code get_src_code_origin :: ErrCtxtStack -> Maybe SrcCodeOrigin -get_src_code_origin (ExpansionCodeCtxt origSrcCode : _) = Just origSrcCode +get_src_code_origin (MkErrCtxt (ExpansionCodeCtxt origSrcCode) _ : _) = Just origSrcCode -- we are in generated code, due to the expansion of the original syntax origSrcCode get_src_code_origin _ = Nothing -- we are in user code, so blame the expression in hand @@ -127,7 +125,6 @@ get_src_code_origin _ = Nothing data TcLclCtxt = TcLclCtxt { tcl_loc :: RealSrcSpan, -- Source span - tcl_in_gen_code :: Bool, tcl_err_ctxt :: ErrCtxtStack, -- See Note [Error Context Stack] tcl_tclvl :: TcLevel, tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, @@ -199,33 +196,34 @@ setLclEnvErrCtxt :: ErrCtxtStack -> TcLclEnv -> TcLclEnv setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt }) addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -addLclEnvErrCtxt (ExpansionCodeCtxt co) = setLclEnvSrcCodeOrigin co -addLclEnvErrCtxt ec = modifyLclCtxt (\env -> if (tcl_in_gen_code env) +addLclEnvErrCtxt ec@(MkErrCtxt (ExpansionCodeCtxt _) _) = setLclEnvSrcCodeOrigin ec +addLclEnvErrCtxt ec = modifyLclCtxt (\env -> if lclCtxtInGeneratedCode env then env -- no op if we are in generated code else env { tcl_err_ctxt = ec : (tcl_err_ctxt env) }) getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_err_ctxt . tcl_lcl_ctxt -setLclEnvSrcCodeOrigin :: SrcCodeOrigin -> TcLclEnv -> TcLclEnv -setLclEnvSrcCodeOrigin o = modifyLclCtxt (setLclCtxtSrcCodeOrigin o) - -setLclCtxtInGenCode :: TcLclCtxt -> TcLclCtxt -setLclCtxtInGenCode lclCtxt = lclCtxt { tcl_in_gen_code = True } - -setLclCtxtInUserCode :: TcLclCtxt -> TcLclCtxt -setLclCtxtInUserCode lclCtxt = lclCtxt { tcl_in_gen_code = False } +setLclEnvSrcCodeOrigin :: ErrCtxt -> TcLclEnv -> TcLclEnv +setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec) -- See Note [ErrCtxt Stack Manipulation] -setLclCtxtSrcCodeOrigin :: SrcCodeOrigin -> TcLclCtxt -> TcLclCtxt -setLclCtxtSrcCodeOrigin o lclCtxt - | (ExpansionCodeCtxt _ : ec) <- tcl_err_ctxt lclCtxt - = lclCtxt { tcl_err_ctxt = ExpansionCodeCtxt o : ec } +setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt +setLclCtxtSrcCodeOrigin ec lclCtxt + | MkErrCtxt (ExpansionCodeCtxt PopErrCtxt) _ <- ec + = lclCtxt { tcl_err_ctxt = tail (tcl_err_ctxt lclCtxt) } + | MkErrCtxt (ExpansionCodeCtxt _) _ : ecs <- tcl_err_ctxt lclCtxt + , MkErrCtxt (ExpansionCodeCtxt _) _ <- ec + = lclCtxt { tcl_err_ctxt = ec : ecs } | otherwise - = lclCtxt { tcl_err_ctxt = ExpansionCodeCtxt o : tcl_err_ctxt lclCtxt } + = lclCtxt { tcl_err_ctxt = ec : tcl_err_ctxt lclCtxt } lclCtxtInGeneratedCode :: TcLclCtxt -> Bool -lclCtxtInGeneratedCode = tcl_in_gen_code +lclCtxtInGeneratedCode lclCtxt + | (MkErrCtxt (ExpansionCodeCtxt _) _ : _) <- tcl_err_ctxt lclCtxt + = True + | otherwise + = False lclEnvInGeneratedCode :: TcLclEnv -> Bool lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -829,7 +829,6 @@ exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (OrigExpr e) exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (OrigExpr e) exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o -exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) @@ -882,6 +881,7 @@ pprCtOrigin (ExpansionOrigin o) OrigExpr (ExplicitList{}) -> text "an overloaded list" OrigExpr (HsIf{}) -> text "an if-then-else expression" OrigExpr e -> text "the expression" <+> (ppr e) + PopErrCtxt -> text "Shouldn't Happen PopErrCtxt" pprCtOrigin (GivenSCOrigin sk d blk) = vcat [ ctoHerald <+> pprSkolInfo sk @@ -1113,6 +1113,7 @@ ppr_br (ExpansionOrigin (OrigExpr (HsIf{}))) = text "an if-then-else expression" ppr_br (ExpansionOrigin (OrigExpr e)) = text "an expression" <+> ppr e ppr_br (ExpansionOrigin (OrigStmt{})) = text "a do statement" ppr_br (ExpansionOrigin (OrigPat{})) = text "a do statement" +ppr_br (ExpansionOrigin PopErrCtxt) = text "SHOULDN'T HAPPEN POPERRORCTXT" ppr_br (ExpectedTySyntax o _) = ppr_br o ppr_br (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator" ppr_br (ExpectedFunTyViewPat{}) = text "a view pattern" ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -63,7 +63,7 @@ module GHC.Tc.Utils.Monad( -- * Error management getSrcCodeOrigin, getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, - inGeneratedCode, setInGeneratedCode, setInUserCode, setLclCtxtInGenCode, + inGeneratedCode, -- setInGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, @@ -88,6 +88,7 @@ module GHC.Tc.Utils.Monad( -- * Context management for the type checker getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, + addExpansionErrCtxt, addExpansionErrCtxtM, addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv, -- * Diagnostic message generation (type checker) @@ -418,7 +419,6 @@ initTcWithGbl hsc_env gbl_env loc do_this tcl_lcl_ctxt = TcLclCtxt { tcl_loc = loc, -- tcl_loc should be over-ridden very soon! - tcl_in_gen_code = False, tcl_err_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topLevel, @@ -1078,10 +1078,10 @@ inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -- See Note [Error contexts in generated code] setSrcSpan (RealSrcSpan loc _) thing_inside - = updLclCtxt (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) thing_inside + = updLclCtxt (\env -> env { tcl_loc = loc }) thing_inside setSrcSpan (UnhelpfulSpan _) thing_inside - = updLclCtxt setLclCtxtInGenCode thing_inside + = thing_inside getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin) getSrcCodeOrigin = @@ -1095,13 +1095,10 @@ getSrcCodeOrigin = -- -- See Note [Error contexts in generated code] -- See Note [Error Context Stack] -setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a -setInGeneratedCode sco thing_inside = - updLclCtxt setLclCtxtInGenCode $ - updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside - -setInUserCode :: TcRn a -> TcRn a -setInUserCode = updLclCtxt setLclCtxtInUserCode +-- setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a +-- setInGeneratedCode sco thing_inside = +-- -- updLclCtxt setLclCtxtInGenCode $ +-- updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) @@ -1349,12 +1346,20 @@ addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) +addExpansionErrCtxt :: SrcCodeOrigin -> ErrCtxtMsg -> TcM a -> TcM a +{-# INLINE addExpansionErrCtxt #-} -- Note [Inlining addErrCtxt] +addExpansionErrCtxt o msg = addExpansionErrCtxtM o (\env -> return (env, msg)) + -- | Add a message to the error context. This message may do tidying. -- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] -addErrCtxtM ctxt = pushCtxt (UserCodeCtxt (False, ctxt)) +addErrCtxtM ctxt = pushCtxt (MkErrCtxt VanillaUserSrcCode ctxt) + +addExpansionErrCtxtM :: SrcCodeOrigin -> (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a +{-# INLINE addExpansionErrCtxtM #-} -- Note [Inlining addErrCtxt] +addExpansionErrCtxtM o ctxt = pushCtxt (MkErrCtxt (ExpansionCodeCtxt o) ctxt) -- | Add a fixed landmark message to the error context. A landmark -- message is always sure to be reported, even if there is a lot of @@ -1368,7 +1373,7 @@ addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) -- and tidying. addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] -addLandmarkErrCtxtM ctxt = pushCtxt (UserCodeCtxt (True, ctxt)) +addLandmarkErrCtxtM ctxt = pushCtxt (MkErrCtxt LandmarkUserSrcCode ctxt) -- | NB. no op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr @@ -1840,18 +1845,17 @@ mkErrCtxt env ctxts where go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] go _ _ _ [] = return [] - go dbg n env (UserCodeCtxt (is_landmark, ctxt) : ctxts) - | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg + go dbg n env (MkErrCtxt LandmarkUserSrcCode ctxt : ctxts) + | n < mAX_CONTEXTS -- Too verbose || dbg = do { (env', msg) <- liftZonkM $ ctxt env - ; let n' = if is_landmark then n else n+1 - ; rest <- go dbg n' env' ctxts + ; rest <- go dbg n env' ctxts ; return (msg : rest) } | otherwise = go dbg n env ctxts - go dbg n env (ExpansionCodeCtxt co : ctxts) + go dbg n env (MkErrCtxt _ ctxt : ctxts) | n < mAX_CONTEXTS -- Too verbose || dbg - = do { let msg = srcCodeOriginErrCtxMsg co - ; rest <- go dbg (n+1) env ctxts + = do { (env', msg) <- liftZonkM $ ctxt env + ; rest <- go dbg (n+1) env' ctxts ; return (msg : rest) } | otherwise = go dbg n env ctxts View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/054cd63d539fd12e30ce21437a8006d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/054cd63d539fd12e30ce21437a8006d... You're receiving this email because of your account on gitlab.haskell.org.