Simon Peyton Jones pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 4b99e8e7 by Simon Peyton Jones at 2026-03-21T21:54:07+00:00 Tidying up from Simon - - - - - 14 changed files: - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -1447,7 +1447,7 @@ mkErrorReport :: CtLocEnv -- ^ Suggested fixes -> TcM (MsgEnvelope TcRnMessage) mkErrorReport tcl_env msg mb_ctxt supp hints - = do { mb_context <- traverse (\ ctxt -> mkErrCtxt (cec_tidy ctxt) (ctl_ctxt tcl_env)) mb_ctxt + = do { mb_context <- traverse (\ ctxt -> tidyErrCtxt (cec_tidy ctxt) (ctl_ctxt tcl_env)) mb_ctxt ; unit_state <- hsc_units <$> getTopEnv ; hfdc <- getHoleFitDispConfig ; let ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7650,7 +7650,7 @@ pprTypeSyntaxName ContextArrowSyntax = "context arrow (=>)" pprTypeSyntaxName FunctionArrowSyntax = "function type arrow (->)" -------------------------------------------------------------------------------- --- ErrCtxt +-- HsCtxt pprTyConInstFlavour :: TyConInstFlavour -> SDoc pprTyConInstFlavour ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -957,8 +957,8 @@ addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside , ppr arg , ppr arg_no]) ; setSrcSpanA arg_loc $ - addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $ - thing_inside + addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $ + thing_inside } | otherwise = do { traceTc "addArgCtxt" (vcat [text "generated Head" @@ -966,8 +966,9 @@ addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside , ppr app_head_lspan , ppr arg_loc , ppr arg]) - ; addLExprCtxt (locA arg_loc) arg $ - thing_inside + ; setSrcSpanA arg_loc $ + addExprCtxt arg $ + thing_inside } @@ -2012,17 +2013,21 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ , eaql_res_rho = app_res_rho }) }}} -mk_origin :: SrcSpan -- SrcSpan of the argument +mk_origin :: SrcSpan -- SrcSpan of the function -> HsExpr GhcRn -- The head of the expression application chain -> TcM CtOrigin mk_origin fun_lspan rn_fun | not (isGeneratedSrcSpan fun_lspan) = return $ exprCtOrigin rn_fun - | otherwise -- if the location is generated, - -- the best we can do is to approximate by looking on top of the error message stack - = do { code_orig <- getHsCtxt - ; traceTc "mk_origin" (pprHsCtxt code_orig) - ; return $ hsCtxtCtOrigin code_orig + + | otherwise -- If the location is generated, the best we can do is to + -- approximate by looking on top of the error message stack + = do { err_ctxt_stack <- getErrCtxt + ; let hs_ctxt = case err_ctxt_stack of + (c:_) -> c + [] -> pprPanic "mk_origin" (ppr rn_fun) + ; traceTc "mk_origin" (pprHsCtxt hs_ctxt) + ; return $ hsCtxtCtOrigin hs_ctxt } ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -122,7 +122,8 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcPolyLExpr (L loc expr) res_ty - = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] + = setSrcSpanA loc $ + addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } @@ -250,9 +251,11 @@ tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr Ghc tcInferExpr = tc_infer_expr IFRR_Any tcInferExprNC = tc_infer_expr_NC IFRR_Any -tc_infer_expr, tc_infer_expr_NC :: InferFRRFlag -> InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) +tc_infer_expr, tc_infer_expr_NC :: InferFRRFlag -> InferInstFlag + -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) tc_infer_expr ifrr iif (L loc expr) - = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] + = setSrcSpanA loc $ + addExprCtxt expr $ -- Note [Error contexts in generated code] do { (expr', rho) <- runInfer iif ifrr (tcExpr expr) ; return (L loc expr', rho) } @@ -278,9 +281,10 @@ tcMonoLExpr, tcMonoLExprNC -> TcM (LHsExpr GhcTc) tcMonoLExpr (L loc expr) res_ty - = do addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] - do { expr' <- tcExpr expr res_ty - ; return (L loc expr') } + = setSrcSpanA loc $ + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } tcMonoLExprNC (L loc expr) res_ty = setSrcSpanA loc $ @@ -813,9 +817,9 @@ The rest of this Note explains how that is done. where `ee` is the expansion of the user written thing `ue` * The type checker context has 3 key fields that describe the context: - TcLclCtxt { tcl_loc :: RealSrcSpan + TcLclCtxt { tcl_loc :: RealSrcSpan , tcl_in_gen_code :: Bool - , tcl_err_ctxt :: [ErrCtxt] + , tcl_err_ctxt :: ErrCtxtStack , ... } Note `tcl_loc` always points to a real place in the source code, hence `RealSrcSpan`. @@ -831,24 +835,20 @@ The rest of this Note explains how that is done. * Now, when tcMonoLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - gets a located expression, it does 2 things: - (a) Calls `addLExprCtxt` to perform error context management - (b) Calls `tcExpr` to typecheck the expression. - -(a) `addLExprCtxt span expr` - (1) updates the location of `tcl_loc` with the `span` above, - (2) adds an `ErrCtxt` on top of the `tcl_err_ctxt`. + gets a located expression, it does 3 things: + (a) Calls `setSrcSpanA` to set the ambient source-code location + (b) Calls `addExprCtxt` to add a suitable `HsCtxt` on top of the `tcl_err_ctxt`. + (c) Calls `tcExpr` to typecheck the expression. -* However, if the `span` is generated (see `isGeneratedSrcSpan`), then - `addLExprCtxt` sets `tcl_in_gen_code` to `True` via a call to `setSrcSpan` - and the `tcl_err_ctxt` is left untouched. Crucially, when we generate code in `expandExpr`, - all the generated AST notes are tagged with a `GeneratedSrcSpan`. This - is how we avoid populating the TcLclCtxt with generated code. +* In these calls, if the `span` is generated (see `isGeneratedSrcSpan`), then + - `setSrcSpanA` sets `tcl_in_gen_code` to `True` + - `addErrCtxt` is a no-op if `tcl_in_gen_code` is True + This is how we avoid populating the TcLclCtxt with generated code. * The type checker error-stack element `GHC.Tc.Types.ErrCtxt.HsCtxt` just stores an error message - type ErrCtxt = HsCtxt + type ErrCtxtStack = [HsCtxt] When called on an `XExpr`, `addLExprCtxt`, adds the user written thing `ue`, and the error message provided by the caller on the `ErrCtxtStack` See ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -473,7 +473,8 @@ tcInferAppHead_maybe fun = case fun of -with_get_ds :: TcM (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, DeepSubsumptionFlag, TcSigmaType) +with_get_ds :: TcM (HsExpr GhcTc, TcSigmaType) + -> TcM (HsExpr GhcTc, DeepSubsumptionFlag, TcSigmaType) with_get_ds mthing = do { (expr_tc, sig_ty) <- mthing ; ds_flag <- getDeepSubsumptionFlag_DataConHead expr_tc ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -405,7 +405,7 @@ so that tcPat can extend the environment for the thing_inside, but also so that constraints arising in the thing_inside can be discharged by the pattern. -This does not work so well for the ErrCtxt carried by the monad: we don't +This does not work so well for the HsCtxt carried by the monad: we don't want the error-context for the pattern to scope over the RHS. Hence the getErrCtxt/setErrCtxt stuff in tcMultiple -} ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -34,7 +34,7 @@ module GHC.Tc.Types( FrontendResult(..), -- Renamer types - ErrCtxt, + HsCtxt, ImportAvails(..), emptyImportAvails, plusImportAvails, ImportUserSpec(..), ImpUserList(..), ===================================== compiler/GHC/Tc/Types/CtLoc.hs ===================================== @@ -439,7 +439,7 @@ pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl}) -- when reporting errors, see `setCtLocM`. -- -- See also 'TcLclCtxt'. -data CtLocEnv = CtLocEnv { ctl_ctxt :: ![ErrCtxt] +data CtLocEnv = CtLocEnv { ctl_ctxt :: !ErrCtxtStack , ctl_loc :: !RealSrcSpan , ctl_bndrs :: !TcBinderStack , ctl_tclvl :: !TcLevel ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -1,9 +1,10 @@ {-# LANGUAGE UndecidableInstances #-} module GHC.Tc.Types.ErrCtxt - ( ErrCtxt, HsCtxt(..), isHsCtxtLandmark + ( HsCtxt(..), isHsCtxtLandmark , UserSigType(..), FunAppCtxtFunArg(..) , TyConInstFlavour(..) + , ErrCtxtStack -- * UserTypeCtxt , UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe @@ -51,6 +52,7 @@ import qualified Data.List.NonEmpty as NE {- ********************************************************************* * * UserTypeCtxt +b * * ********************************************************************* -} @@ -195,19 +197,14 @@ isSigMaybe _ = Nothing {- ********************************************************************* * * - ErrCtxt + HsCtxt + Error message contexts * * ********************************************************************* -} --------------------------------------------------------------------------------- --- type HsCtxtM = TidyEnv -> ZonkM (TidyEnv, HsCtxt) - --- | Additional context to include in an error message, e.g. --- "In the type signature ...", "In the ambiguity check for ...", etc. -type ErrCtxt = HsCtxt - --------------------------------------------------------------------------------- --- Error message contexts +-- An error-context stack (maintained in the typehcecker's monad) +-- is just a stack of HsCtxts +type ErrCtxtStack = [HsCtxt] data UserSigType = UserLHsSigType !(LHsSigType GhcRn) ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -21,7 +21,6 @@ module GHC.Tc.Types.LclEnv ( , setLclEnvTypeEnv , modifyLclEnvTcLevel - , getLclEnvHsCtxt , setLclEnvHsCtxt , setLclCtxtHsCtxt , lclEnvInGeneratedCode @@ -90,34 +89,6 @@ data TcLclEnv -- Changes as we move inside an expression tcl_errs :: TcRef (Messages TcRnMessage) -- Place to accumulate diagnostics } -{- - -Note [ErrCtxtStack Manipulation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ErrCtxtStack is a list of ErrCtxt - -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 `ExpansionCodeCtxt` - - the current expression being typechecked is compiler generated/expanded; - - the original source code thing is stored in `src_code_origin` field. - - the `src_code_origin` is what will be used in the error message displayed to the user - -In the current design, if the top of the ErrCtxtStack is an ExpansionCodeCtxt -i.e. we are currently typechecking a compiler generated expression, and we encounter -an XExpr, then we _replace_ the top of the stack with the new XExpr. Otherwise, we -push the new expression error message on top of the stack. cf. `LclEnv.setLclCtxtHsCtxt` - --} - - --- See Note [ErrCtxtStack Manipulation] -type ErrCtxtStack = [ErrCtxt] - -- | Get the top of the error message stack get_err_ctxt_stack_head :: ErrCtxtStack -> HsCtxt get_err_ctxt_stack_head (e : _) = e @@ -127,7 +98,7 @@ data TcLclCtxt = TcLclCtxt { tcl_loc :: RealSrcSpan, -- Source span tcl_in_gen_code :: Bool, -- Are we type checking a generated expression? - tcl_err_ctxt :: ErrCtxtStack, -- See Note [ErrCtxtStack Manipulation] + tcl_err_ctxt :: ErrCtxtStack, tcl_tclvl :: TcLevel, tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, -- and for tidying type @@ -191,26 +162,23 @@ setLclEnvLoc loc = modifyLclCtxt (\lenv -> lenv { tcl_loc = loc }) getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc . tcl_lcl_ctxt -getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt] +getLclEnvErrCtxt :: TcLclEnv -> ErrCtxtStack getLclEnvErrCtxt = tcl_err_ctxt . tcl_lcl_ctxt setLclEnvErrCtxt :: ErrCtxtStack -> TcLclEnv -> TcLclEnv setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt }) -- See Note [ErrCtxtStack Manipulation] -addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv +addLclEnvErrCtxt :: HsCtxt -> TcLclEnv -> TcLclEnv addLclEnvErrCtxt ec = setLclEnvHsCtxt ec -getLclEnvHsCtxt :: TcLclEnv -> HsCtxt -getLclEnvHsCtxt = get_err_ctxt_stack_head . tcl_err_ctxt . tcl_lcl_ctxt - -setLclEnvHsCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv +setLclEnvHsCtxt :: HsCtxt -> TcLclEnv -> TcLclEnv setLclEnvHsCtxt ec = modifyLclCtxt (setLclCtxtHsCtxt ec) -- See Note [ErrCtxtStack Manipulation] -setLclCtxtHsCtxt :: ErrCtxt -> TcLclCtxt -> TcLclCtxt +setLclCtxtHsCtxt :: HsCtxt -> TcLclCtxt -> TcLclCtxt setLclCtxtHsCtxt ec lclCtxt - -- never stack 2 statement error contexts on top of each other + -- Never stack 2 statement error contexts on top of each other | StmtErrCtxt{} : ecs <- tcl_err_ctxt lclCtxt , StmtErrCtxt{} <- ec = lclCtxt { tcl_err_ctxt = ec : ecs } ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -61,7 +61,6 @@ module GHC.Tc.Utils.Monad( addDependentFiles, addDependentDirectories, -- * Error management - getHsCtxt, getSrcSpanM, getRealSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, @@ -88,7 +87,7 @@ module GHC.Tc.Utils.Monad( -- * Context management for the type checker getErrCtxt, setErrCtxt, addErrCtxt, - addLExprCtxt, + addExprCtxt, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv, -- * Diagnostic message generation (type checker) @@ -98,7 +97,7 @@ module GHC.Tc.Utils.Monad( checkTc, checkTcM, checkJustTc, checkJustTcM, failIfTc, failIfTcM, - mkErrCtxt, + tidyErrCtxt, addTcRnDiagnostic, addDetailedDiagnostic, mkTcRnMessage, reportDiagnostic, reportDiagnostics, warnIf, diagnosticTc, diagnosticTcM, @@ -1086,7 +1085,15 @@ inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -- See Note [Error contexts in generated code] --- NB: This is the only place where tcl_in_gen_code is modified +-- When entering a node decorated with a /user/ span: +-- * Record that span in `tcl_loc` +-- * Set `tcl_in_gen_code` to False, to record that we +-- are in user code. +-- When entering a node decorated with a /generated/ span: +-- * Do not touch `tcl_loc`, so that `tcl_loc` always records +-- the innermost user span. +-- NB: This is the only place where `tcl_loc` and `tcl_in_gen_code` +-- are modified setSrcSpan (RealSrcSpan loc _) thing_inside = updLclCtxt (\ctxt -> ctxt {tcl_loc = loc, tcl_in_gen_code = False}) thing_inside setSrcSpan (GeneratedSrcSpan{}) thing_inside @@ -1094,9 +1101,6 @@ setSrcSpan (GeneratedSrcSpan{}) thing_inside setSrcSpan _ thing_inside = thing_inside -getHsCtxt :: TcRn HsCtxt -getHsCtxt = getLclEnvHsCtxt <$> getLclEnv - setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) @@ -1177,7 +1181,7 @@ addErrAt :: SrcSpan -> TcRnMessage -> TcRn () -- work doesn't matter addErrAt loc msg = do { ctxt <- getErrCtxt ; tidy_env <- liftZonkM $ tcInitTidyEnv - ; err_ctxt <- mkErrCtxt tidy_env ctxt + ; err_ctxt <- tidyErrCtxt tidy_env ctxt ; let detailed_msg = mkDetailedMessage (ErrInfo err_ctxt Nothing noHints) msg ; add_long_err_at loc detailed_msg } @@ -1314,57 +1318,49 @@ problem. Note [Error contexts in generated code] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* setSrcSpan is the only place that modifies `tcl_in_gen_code` +* setSrcSpan is the only place that modifies `tcl_loc` and `tcl_in_gen_code` -* addLExpr updates updates the ErrCtxt stored in LclEnv with the following logic - - If the `SrcSpan` is a `RealSrcSpan`, `setSrcSpan` updates the `tcl_loc` to the given value - and sets `tcl_in_gen_code` to `False`. Meaning we are not type checking a compiler generated - expression. And thus it can add the expression on to the ErrCtxt Stack - - If the `SrcSpan` is a GeneratedSrcSpan then `tcl_in_gen_code` is set to `True`, meaning - the expression in hand is compiler generated, and hence it is not added on to the stack. +* addLExpr updates updates the HsCtxt stored in LclEnv with the following logic + - If `tcl_in_gen_code` is true, do nothing + - Otherwise push a suitable HsCtxt onto the ErrCtxtStack This ensures that the error messages do not leak compiler generated expressions which can be confusing to the users as they never appear in the original source code - - See Note [Rebindable syntax and XXExprGhcRn] in `GHC.Hs.Expr` for -more discussion of this fancy footwork + 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 [ErrCtxtStack Manipulation] in `GHC.Tc.Types.LclEnv` for info about `ErrCtxtStack` + relation with pattern-match checks -} -- See Note [Error contexts in generated code] -addLExprCtxt :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a -addLExprCtxt lspan e thing_inside - = setSrcSpan lspan $ add_expr_ctxt e thing_inside - where - add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a - add_expr_ctxt e thing_inside - = do { igc <- inGeneratedCode - ; if igc -- generated - then thing_inside - else case e of - -- The HsHole special case addresses situations like - -- f x = _ - -- when we don't want to say "In the expression: _", - -- because it is mentioned in the error message itself - HsHole{} -> thing_inside - - -- There is a special case for expressions with signatures to avoid having too verbose - -- error context. c.f. RecordDotSyntaxFail9 - -- Add the original HsCtxt if we are typechecking an expanded expression - ExprWithTySig _ (L _ e') _ - | XExpr (ExpandedThingRn (HSE o _)) <- e' -> addErrCtxt o thing_inside - XExpr (ExpandedThingRn (HSE o _)) -> addErrCtxt o thing_inside - - _ -> addErrCtxt (ExprCtxt e) thing_inside - } - -getErrCtxt :: TcM [ErrCtxt] +addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a +addExprCtxt e thing_inside + = do { igc <- inGeneratedCode + ; if igc -- In generated code; so addExprCtxt is a no-op + then thing_inside + else case e of + -- The HsHole special case addresses situations like + -- f x = _ + -- when we don't want to say "In the expression: _", + -- because it is mentioned in the error message itself + HsHole{} -> thing_inside + + -- There is a special case for expressions with signatures to avoid having + -- too verbose error context. c.f. RecordDotSyntaxFail9 + -- Add the original HsCtxt if we are typechecking an expanded expression + ExprWithTySig _ (L _ e') _ + | XExpr (ExpandedThingRn (HSE o _)) <- e' -> addErrCtxt o thing_inside + + XExpr (ExpandedThingRn (HSE o _)) -> addErrCtxt o thing_inside + + _ -> addErrCtxt (ExprCtxt e) thing_inside + } + +getErrCtxt :: TcM ErrCtxtStack getErrCtxt = do { env <- getLclEnv; return (getLclEnvErrCtxt env) } -setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a +setErrCtxt :: ErrCtxtStack -> TcM a -> TcM a {-# INLINE setErrCtxt #-} -- Note [Inlining addErrCtxt] setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) @@ -1374,7 +1370,7 @@ addErrCtxt :: HsCtxt -> TcM a -> TcM a addErrCtxt ctxt = pushCtxt ctxt -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr -pushCtxt :: ErrCtxt -> TcM a -> TcM a +pushCtxt :: HsCtxt -> TcM a -> TcM a {-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt] pushCtxt ctxt = updLclEnv (addLclEnvErrCtxt ctxt) @@ -1868,7 +1864,7 @@ addDiagnosticTc msg addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM () addDiagnosticTcM (env0, msg) = do { ctxt <- getErrCtxt - ; extra <- mkErrCtxt env0 ctxt + ; extra <- tidyErrCtxt env0 ctxt ; let detailed_msg = mkDetailedMessage (ErrInfo extra Nothing noHints) msg ; add_diagnostic detailed_msg } @@ -1881,7 +1877,7 @@ addDetailedDiagnostic mkMsg = do !diag_opts <- initDiagOpts <$> getDynFlags env0 <- liftZonkM tcInitTidyEnv ctxt <- getErrCtxt - err_info <- mkErrCtxt env0 ctxt + err_info <- tidyErrCtxt env0 ctxt reportDiagnostic $ mkMsgEnvelope diag_opts loc name_ppr_ctx $ mkMsg err_info @@ -1918,16 +1914,19 @@ add_diagnostic msg -} add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan - -> [ErrCtxt] + -> ErrCtxtStack -> TcM () add_err_tcm tidy_env msg loc ctxt - = do { err_ctxt <- mkErrCtxt tidy_env ctxt + = do { err_ctxt <- tidyErrCtxt tidy_env ctxt ; add_long_err_at loc $ mkDetailedMessage (ErrInfo err_ctxt Nothing noHints) msg } -mkErrCtxt :: TidyEnv -> [ErrCtxt] -> TcM [HsCtxt] --- Tidy the error info, trimming excessive contexts -mkErrCtxt env ctxts +tidyErrCtxt :: TidyEnv -> ErrCtxtStack -> TcM ErrCtxtStack +-- Do the following +-- * Zonk each HsCtxt in the ErrCtxtStack +-- * Tidy each using TidyEnv +-- * Trim excessive contexts +tidyErrCtxt env ctxts -- = do -- dbg <- hasPprDebug <$> getDynFlags -- if dbg -- In -dppr-debug style the output @@ -1935,7 +1934,7 @@ mkErrCtxt env ctxts -- else go dbg 0 env ctxts = go False 0 env ctxts -- regular error ctx where - go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [HsCtxt] + go :: Bool -> Int -> TidyEnv -> ErrCtxtStack -> TcM ErrCtxtStack go _ _ _ [] = return [] go dbg n env (ctxt : ctxts) | isHsCtxtLandmark ctxt ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -2698,11 +2698,11 @@ uType_defer (UE { u_loc = loc, u_defer = ref -- snocBag: see Note [Work-list ordering] in GHC.Tc.Solver.Equality -- Error trace only - -- NB. do *not* call mkErrCtxt unless tracing is on, + -- NB. do *not* call tidyErrCtxt unless tracing is on, -- because it is hugely expensive (#5631) ; whenDOptM Opt_D_dump_tc_trace $ do { ctxt <- getErrCtxt - ; err_ctxt <- mkErrCtxt emptyTidyEnv ctxt + ; err_ctxt <- tidyErrCtxt emptyTidyEnv ctxt ; traceTc "utype_defer" $ vcat ( ppr role : debugPprType ty1 ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -798,6 +798,8 @@ tidyEvVar env var = updateIdTypeAndMult (tidyType env) var zonkTidyHsCtxt :: TidyEnv -> HsCtxt -> ZonkM (TidyEnv, HsCtxt) +-- We zonk and tidy a HsCtxt just before putting it into an error message +-- so that it contains as much info as possible, as tidily as possible zonkTidyHsCtxt env e@(ExprCtxt{}) = return (env, e) zonkTidyHsCtxt env (ThetaCtxt ctxt theta_ty) = do (env', theta_ty') <- zonkTidyTcTypes env theta_ty ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -152,7 +152,7 @@ I.1. GHC.Tc.Zonk.Monad - the ZonkM monad as used in GHC.Tc.Zonk.TcType. Crucially, it never errors. It is the monad we use when reporting errors - (see ErrCtxt), and it would be quite bad if we could error in the middle + (see HsCtxt), and it would be quite bad if we could error in the middle of reporting an error! I.2. GHC.Tc.Zonk.TcType - zonking types in the typechecker View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b99e8e72978299dc8de3a1b8a0ab954... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b99e8e72978299dc8de3a1b8a0ab954... You're receiving this email because of your account on gitlab.haskell.org.