Apoorv Ingle pushed to branch wip/ani/kill-popErrCtxt at Glasgow Haskell Compiler / GHC Commits: 3437dbca by Apoorv Ingle at 2025-10-27T08:39:42-05:00 wibbles - - - - - 9 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Tc/Errors.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/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -681,6 +681,7 @@ data SrcCodeOrigin -- Does not presist post renaming phase -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn] -- in `GHC.Tc.Gen.Do` + -- INVARIANT: SHOULD NEVER APPEAR IN A ExpansionCodeCtxt in CodeSrcFlag ErrCtxt on stack data XXExprGhcRn = ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- The original source thing to be used for error messages ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -26,10 +26,6 @@ import GHC.Driver.Config.Diagnostic import GHC.Rename.Unbound -import Language.Haskell.Syntax (DotFieldOcc (..)) -import Language.Haskell.Syntax.Basic (FieldLabelString (..)) -import GHC.Hs.Expr (SrcCodeOrigin (..), HsExpr (..)) - import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Errors.Types @@ -2394,43 +2390,6 @@ mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped)) in different_names && same_occ_names | otherwise = False - -- See Note [Out-of-scope fields with -XOverloadedRecordDot] - record_field_suggestions :: ErrorItem -> TcM ([ImportError], [GhcHint]) - record_field_suggestions item = flip (maybe $ return ([], noHints)) record_field $ \name -> - do { glb_env <- getGlobalRdrEnv - ; lcl_env <- getLocalRdrEnv - ; let field_name_hints = report_no_fieldnames item - ; (errs, hints) <- if occ_name_in_scope glb_env lcl_env name - then return ([], noHints) - else unknownNameSuggestions emptyLocalRdrEnv WL_RecField (mkRdrUnqual name) - ; pure (errs, hints ++ field_name_hints) - } - - -- get type names from instance - -- resolve the type - if it's in scope is it a record? - -- if it's a record, report an error - the record name + the field that could not be found - report_no_fieldnames :: ErrorItem -> [GhcHint] - report_no_fieldnames item - | Just (EvVarDest evvar) <- ei_evdest item - -- we can assume that here we have a `HasField @Symbol x r a` instance - -- because of GetFieldOrigin in record_field - , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar) - , Just (r_tycon, _) <- tcSplitTyConApp_maybe r - , Just x_name <- isStrLitTy x - -- we check that this is a record type by checking whether it has any - -- fields (in scope) - , not . null $ tyConFieldLabels r_tycon - = [RemindRecordMissingField x_name r a] - | otherwise = [] - - occ_name_in_scope glb_env lcl_env occ_name = not $ - null (lookupGRE glb_env (LookupOccName occ_name (RelevantGREsFOS WantNormal))) && - isNothing (lookupLocalRdrOcc lcl_env occ_name) - - record_field = case orig of - ExpansionOrigin (OrigExpr (HsGetField _ _ (L _ name))) -> Just (mkVarOccFS (field_label $ unLoc $ dfoLabel name)) - _ -> Nothing - {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have an unsolved (Num Int), where `Int` is not the Prelude Int, ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -32,7 +32,7 @@ import GHC.Tc.Gen.HsType import GHC.Tc.Utils.Concrete ( unifyConcrete, idConcreteTvs ) import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence -import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..), ErrCtxt (..) ) +import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..), ErrCtxt (..), CodeSrcFlag (..)) import GHC.Tc.Errors.Ppr (pprErrCtxtMsg) import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType @@ -951,28 +951,23 @@ 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 + MkErrCtxt (ExpansionCodeCtxt{}) _ -> text "<EXPN>" <+> pprErrCtxtMsg y + _ -> text "<USER>" <+> pprErrCtxtMsg y) + (take 4 (zip err_ctx err_ctx_msg))) ]) ; if in_generated_code - then updCtxtForArg (locA arg_loc) arg $ + then updCtxtForArg (L arg_loc arg) $ thing_inside else do setSrcSpanA arg_loc $ addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $ thing_inside } where - updCtxtForArg :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a - updCtxtForArg l@(RealSrcSpan{}) e thing_inside = -- See 2.iii above - do setSrcSpan l $ - addExprCtxt e $ - thing_inside - -- updCtxtForArg (UnhelpfulSpan UnhelpfulGenerated) _ thing_inside = -- See 2.i above - -- thing_inside - updCtxtForArg (UnhelpfulSpan {}) _ thing_inside = -- See 2.ii above - do -- setInUserCode $ - thing_inside + updCtxtForArg :: LHsExpr GhcRn -> TcRn a -> TcRn a + updCtxtForArg e@(L lspan _) thing_inside + = do setSrcSpan (locA lspan) $ + addLExprCtxt e $ -- addLExpr is no op for non-user located exprs + thing_inside ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -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 -- (>>) - [ e -- Span is set because of statement loc + [ e , expand_stmts_expr ] return $ L loc (mkExpandedStmt stmt doFlavour expansion) ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -54,7 +54,6 @@ 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) @@ -125,7 +124,7 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType tcPolyLExpr (L loc expr) res_ty = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - addExprCtxt expr $ -- Note [Error contexts in generated code] + addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } @@ -244,7 +243,7 @@ tcInferRhoNC = tcInferExprNC IIF_DeepRho tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) tcInferExpr iif (L loc expr) = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - addExprCtxt expr $ -- Note [Error contexts in generated code] + addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code] do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr) ; return (L loc expr', rho) } @@ -271,7 +270,7 @@ tcMonoLExpr, tcMonoLExprNC tcMonoLExpr (L loc expr) res_ty = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - addExprCtxt expr $ -- Note [Error contexts in generated code] + addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code] do { expr' <- tcExpr expr res_ty ; return (L loc expr') } @@ -757,11 +756,8 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcXExpr (ExpandedThingRn o e) res_ty - = 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 - tcExpr e res_ty + = 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 ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -26,7 +26,7 @@ module GHC.Tc.Gen.Head , nonBidirectionalErr , pprArgInst - , addExprCtxt, addFunResCtxt ) where + , addExprCtxt, addLExprCtxt, addFunResCtxt ) where import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig ) import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody ) @@ -1108,6 +1108,17 @@ 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{} -> thing_inside -- the err ctxt management done is done by setInGeneratedCode - HsPar{} -> thing_inside -- the err ctxt management done is done by setInGeneratedCode + HsPar{} -> thing_inside + -- We don't want to say 'In the expression (e)', + -- we just want to say 'In the expression, 'e' + -- which will be handeled by the recursive call in thing_inside + XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) thing_inside _ -> addErrCtxt (ExprCtxt e) thing_inside -- no op in generated code + + +addLExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a +addLExprCtxt (L lspan e) thing_inside + | (RealSrcSpan{}) <- locA lspan + = addExprCtxt e thing_inside + | otherwise + = thing_inside ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -63,6 +63,7 @@ data ErrCtxt = MkErrCtxt CodeSrcFlag ErrCtxtMsgM data CodeSrcFlag = VanillaUserSrcCode | LandmarkUserSrcCode | ExpansionCodeCtxt SrcCodeOrigin + -- INVARIANT: SHOULD NEVER APPEAR IN A ExpansionCodeCtxt in CodeSrcFlag ErrCtxt on stack -------------------------------------------------------------------------------- -- Error message contexts ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -196,10 +196,7 @@ setLclEnvErrCtxt :: ErrCtxtStack -> TcLclEnv -> TcLclEnv setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt }) addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -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) }) +addLclEnvErrCtxt ec = setLclEnvSrcCodeOrigin ec getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_err_ctxt . tcl_lcl_ctxt ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -837,7 +837,7 @@ 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 (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) +exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe SrcCodeOrigin -> CtOrigin srcCodeOriginCtOrigin e Nothing = exprCtOrigin e View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3437dbca23d19486a1865d81810136ac... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3437dbca23d19486a1865d81810136ac... You're receiving this email because of your account on gitlab.haskell.org.