Apoorv Ingle pushed to branch wip/ani/kill-popErrCtxt at Glasgow Haskell Compiler / GHC Commits: e95889e1 by Apoorv Ingle at 2025-09-14T22:26:20-05:00 some initial experiment to make ErrCtxt more expressive - - - - - 5 changed files: - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -485,11 +485,11 @@ It stores the original statement (with location) and the expanded expression -- | Wrap a located expression with a `PopErrCtxt` -mkPopErrCtxtExpr :: HsExpr GhcRn -> HsExpr GhcRn -mkPopErrCtxtExpr a = XExpr (PopErrCtxt a) +-- mkPopErrCtxtExpr :: HsExpr GhcRn -> HsExpr GhcRn +-- mkPopErrCtxtExpr a = XExpr (PopErrCtxt a) genPopErrCtxtExpr :: LHsExpr GhcRn -> LHsExpr GhcRn -genPopErrCtxtExpr (L loc a) = L loc (mkPopErrCtxtExpr a) +genPopErrCtxtExpr x = x mkExpandedPatRn :: Pat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn mkExpandedPatRn pat e = XExpr (ExpandedThingRn (OrigPat pat) e) ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -1109,5 +1109,5 @@ addExprCtxt e thing_inside -- f x = _ -- when we don't want to say "In the expression: _", -- because it is mentioned in the error message itself - XExpr (PopErrCtxt _) -> thing_inside -- popErrCtxt shouldn't push ctxt. see typechecking let stmts + XExpr (ExpandedThingRn o _) -> setInGeneratedCode o thing_inside _ -> addErrCtxt (ExprCtxt e) thing_inside -- no op in generated code ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -4,7 +4,7 @@ {-# LANGUAGE UndecidableInstances #-} module GHC.Tc.Types.ErrCtxt - ( ErrCtxt, ErrCtxtMsg(..) + ( ErrCtxt (..), ErrCtxtMsg(..), srcCodeOriginErrCtxMsg , UserSigType(..), FunAppCtxtFunArg(..) , TyConInstFlavour(..) ) @@ -23,7 +23,7 @@ import GHC.Tc.Zonk.Monad ( ZonkM ) import GHC.Types.Basic ( TyConFlavour ) import GHC.Types.Name ( Name ) -import GHC.Types.SrcLoc ( SrcSpan ) +import GHC.Types.SrcLoc ( SrcSpan, unLoc ) import GHC.Types.Var ( Id, TyCoVar ) import GHC.Types.Var.Env ( TidyEnv ) @@ -50,13 +50,18 @@ import qualified Data.List.NonEmpty as NE -- | Additional context to include in an error message, e.g. -- "In the type signature ...", "In the ambiguity check for ...", etc. -type ErrCtxt = (Bool, TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) +data ErrCtxt = UserCodeCtxt (Bool, TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -- Monadic so that we have a chance -- to deal with bound type variables just before error -- message construction -- Bool: True <=> this is a landmark context; do not -- discard it when trimming for display + | GeneratedCodeCtxt SrcCodeOrigin + -- The payload is a SrcCodeOrigin because it is used to generate + -- 1. The CtOrigin for CtLoc, and + -- 2. ErrCtxtMsg in error messages + -------------------------------------------------------------------------------- -- Error message contexts @@ -221,3 +226,9 @@ data ErrCtxtMsg | MergeSignaturesCtxt !UnitState !ModuleName ![InstantiatedModule] -- | While checking that a module implements a Backpack signature. | CheckImplementsCtxt !UnitState !Module !InstantiatedModule + + +srcCodeOriginErrCtxMsg :: SrcCodeOrigin -> ErrCtxtMsg +srcCodeOriginErrCtxMsg (OrigExpr e) = ExprCtxt e +srcCodeOriginErrCtxMsg (OrigStmt s f) = StmtErrCtxt (HsDoStmt f) (unLoc s) +srcCodeOriginErrCtxMsg (OrigPat p) = PatCtxt p ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Tc.Types.LclEnv ( , addLclEnvErrCtxt - , ErrCtxtStack (..) + , ErrCtxtStack , ArrowCtxt(..) , ThBindEnv , TcTypeEnv @@ -109,36 +109,24 @@ This data structure keeps track of two things: -- See Note [Error Context Stack] -data ErrCtxtStack - = 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 +type ErrCtxtStack = [ErrCtxt] -- | Are we in a generated context? isGeneratedCodeCtxt :: ErrCtxtStack -> Bool -isGeneratedCodeCtxt UserCodeCtxt{} = False -isGeneratedCodeCtxt _ = True +isGeneratedCodeCtxt (GeneratedCodeCtxt{} : _) = True +isGeneratedCodeCtxt _ = False -- | 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 +get_src_code_origin (GeneratedCodeCtxt es : _) = Just 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 a generated context should be ignored - +get_src_code_origin _ = Nothing + -- we are in user code, so blame the expression in hand data TcLclCtxt = TcLclCtxt { tcl_loc :: RealSrcSpan, -- Source span - tcl_ctxt :: ErrCtxtStack, -- See Note [Error Context Stack] + tcl_err_ctxt :: ErrCtxtStack, -- See Note [Error Context Stack] tcl_tclvl :: TcLevel, tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, -- and for tidying type @@ -203,25 +191,30 @@ getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc . tcl_lcl_ctxt getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt] -getLclEnvErrCtxt = lcl_err_ctxt . tcl_ctxt . tcl_lcl_ctxt +getLclEnvErrCtxt = tcl_err_ctxt . tcl_lcl_ctxt setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv -setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ _ -> ctxt) (tcl_ctxt env) }) +setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt }) addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -addLclEnvErrCtxt ec = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ctxt -> ec : ctxt) (tcl_ctxt env) }) +addLclEnvErrCtxt (GeneratedCodeCtxt co) = setLclEnvSrcCodeOrigin co +addLclEnvErrCtxt ec = modifyLclCtxt (\env -> env { tcl_err_ctxt = ec : (tcl_err_ctxt env) }) getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin -getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_ctxt . tcl_lcl_ctxt +getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_err_ctxt . tcl_lcl_ctxt setLclEnvSrcCodeOrigin :: SrcCodeOrigin -> TcLclEnv -> TcLclEnv setLclEnvSrcCodeOrigin o = modifyLclCtxt (setLclCtxtSrcCodeOrigin o) setLclCtxtSrcCodeOrigin :: SrcCodeOrigin -> TcLclCtxt -> TcLclCtxt -setLclCtxtSrcCodeOrigin o ctxt = ctxt { tcl_ctxt = GeneratedCodeCtxt o (lcl_err_ctxt $ tcl_ctxt ctxt) } +setLclCtxtSrcCodeOrigin o lclCtxt + | (GeneratedCodeCtxt _ : ec) <- tcl_err_ctxt lclCtxt + = lclCtxt { tcl_err_ctxt = GeneratedCodeCtxt o : ec } + | otherwise + = lclCtxt { tcl_err_ctxt = GeneratedCodeCtxt o : tcl_err_ctxt lclCtxt } lclCtxtInGeneratedCode :: TcLclCtxt -> Bool -lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_ctxt +lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_err_ctxt lclEnvInGeneratedCode :: TcLclEnv -> Bool lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -168,6 +168,7 @@ import GHC.Tc.Types -- Re-export all import GHC.Tc.Types.Constraint import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Evidence +import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.LclEnv import GHC.Tc.Types.Origin import GHC.Tc.Types.TcRef @@ -401,7 +402,7 @@ initTcWithGbl hsc_env gbl_env loc do_this tcl_lcl_ctxt = TcLclCtxt { tcl_loc = loc, -- tcl_loc should be over-ridden very soon! - tcl_ctxt = UserCodeCtxt [], + tcl_err_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topLevel, tcl_th_bndrs = emptyNameEnv, @@ -983,9 +984,7 @@ 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_ctxt = UserCodeCtxt (lcl_err_ctxt $ tcl_ctxt env)}) - thing_inside + = updLclCtxt (\env -> env { tcl_loc = loc }) thing_inside setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside @@ -1252,7 +1251,7 @@ addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- 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 (False, ctxt) +addErrCtxtM ctxt = pushCtxt (UserCodeCtxt (False, 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 @@ -1266,7 +1265,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 (True, ctxt) +addLandmarkErrCtxtM ctxt = pushCtxt (UserCodeCtxt (True, ctxt)) -- | NB. no op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr @@ -1277,9 +1276,7 @@ pushCtxt ctxt = updLclEnv (updCtxt ctxt) updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -- Do not update the context if we are in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr -updCtxt ctxt env - | lclEnvInGeneratedCode env = env - | otherwise = addLclEnvErrCtxt ctxt env +updCtxt ctxt env = addLclEnvErrCtxt ctxt env popErrCtxt :: TcM a -> TcM a popErrCtxt thing_inside = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $ @@ -1740,7 +1737,7 @@ mkErrCtxt env ctxts where go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] go _ _ _ [] = return [] - go dbg n env ((is_landmark, ctxt) : ctxts) + go dbg n env (UserCodeCtxt (is_landmark, ctxt) : ctxts) | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg = do { (env', msg) <- liftZonkM $ ctxt env ; let n' = if is_landmark then n else n+1 @@ -1748,6 +1745,13 @@ mkErrCtxt env ctxts ; return (msg : rest) } | otherwise = go dbg n env ctxts + go dbg n env (GeneratedCodeCtxt co : ctxts) + | n < mAX_CONTEXTS -- Too verbose || dbg + = do { let msg = srcCodeOriginErrCtxMsg co + ; rest <- go dbg (n+1) env ctxts + ; return (msg : rest) } + | otherwise + = go dbg n env ctxts mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e95889e1d3d604fb26b23d44e1d81731... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e95889e1d3d604fb26b23d44e1d81731... You're receiving this email because of your account on gitlab.haskell.org.