Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 1bf47a14 by Apoorv Ingle at 2025-11-03T11:15:02-06:00 simplify addArgCtxt and push setSrcSpan inside addLExprCtxt. Make sure addExprCtxt is not called by itself - - - - - 3 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -32,8 +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 (..), CodeSrcFlag (..)) -import GHC.Tc.Errors.Ppr (pprErrCtxtMsg) +import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..) ) import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType import GHC.Tc.Utils.Concrete( hasFixedRuntimeRep_syntactic ) @@ -939,43 +938,22 @@ looks_like_type_arg _ = False addArgCtxt :: Int -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn -> TcM a -> TcM a -- There are 2 cases: --- 1. In the normal case, we add an informative context (<=> `inGeneratedCode` is `False`) +-- 1. In the normal case, we add an informative context +-- (<=> location span of f or head of application chain is user located) -- "In the third argument of f, namely blah" --- 2. If we are inside generated code (<=> `inGeneratedCode` is `True`) --- (i) If arg_loc is generated do nothing to to LclEnv/LclCtxt --- (ii) If arg_loc is Unhelpful UnhelpfulNoLocationInfo set `tcl_in_gen_code` to `True` --- (iii) if arg_loc is RealSrcLoc then update tcl_loc and add "In the expression: arg" to ErrCtxtStack +-- 2. If head of the application chain is generated +-- "In the expression: arg" + -- 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, fun_lspan) (L arg_loc arg) thing_inside - = do { in_generated_code <- inGeneratedCode - ; err_ctx <- getErrCtxt - ; env0 <- liftZonkM tcInitTidyEnv - ; err_ctx_msg <- mkErrCtxt env0 err_ctx - ; traceTc "addArgCtxt" (vcat [ text "generated:" <+> ppr in_generated_code - , text "arg: " <+> ppr (arg, arg_no) - , text "arg_loc:" <+> ppr arg_loc - , text "fun:" <+> ppr fun - , text "fun_lspan" <+> ppr fun_lspan - , 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 not (isGeneratedSrcSpan fun_lspan) - then setSrcSpanA arg_loc $ - addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $ - thing_inside - else updCtxtForArg (L arg_loc arg) $ - thing_inside - } - where - 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 +addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside + | isGoodSrcSpan app_head_lspan + = setSrcSpanA arg_loc $ + addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $ + thing_inside + | otherwise + = addLExprCtxt (locA arg_loc) arg $ + thing_inside ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -121,8 +121,7 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcPolyLExpr (L loc expr) res_ty - = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code] + = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } @@ -240,8 +239,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 - addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code] + = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr) ; return (L loc expr', rho) } @@ -267,8 +265,7 @@ tcMonoLExpr, tcMonoLExprNC -> TcM (LHsExpr GhcTc) tcMonoLExpr (L loc expr) res_ty - = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code] + = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] do { expr' <- tcExpr expr res_ty ; return (L loc expr') } ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -26,7 +26,7 @@ module GHC.Tc.Gen.Head , nonBidirectionalErr , pprArgInst - , addExprCtxt, addLExprCtxt, addFunResCtxt ) where + , addLExprCtxt, addFunResCtxt ) where import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig ) import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody ) @@ -1101,8 +1101,9 @@ mis-match in the number of value arguments. * * ********************************************************************* -} -addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a -addExprCtxt e thing_inside +-- | !Caution!: Users should not call add_expr_ctxt, they ought to use addLExprCtxt +add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a +add_expr_ctxt e thing_inside = case e of HsHole _ -> thing_inside -- The HsHole special case addresses situations like @@ -1117,12 +1118,12 @@ addExprCtxt e 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 +addLExprCtxt :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a +addLExprCtxt lspan e thing_inside + | isGoodSrcSpan lspan , (HsPar _ e') <- e - = addExprCtxt (unLoc e') thing_inside - | (RealSrcSpan{}) <- locA lspan - = addExprCtxt e thing_inside + = setSrcSpan lspan $ add_expr_ctxt (unLoc e') thing_inside + | isGoodSrcSpan lspan + = setSrcSpan lspan $ add_expr_ctxt e thing_inside | otherwise = thing_inside View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1bf47a14280055339c404f572cd5b0c2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1bf47a14280055339c404f572cd5b0c2... You're receiving this email because of your account on gitlab.haskell.org.