[Git][ghc/ghc][wip/spj-apporv-Oct24] simplify addArgCtxt and push setSrcSpan inside addLExprCtxt. Make sure...

3 Nov 2025

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.

    

Apoorv Ingle (＠ani)

tags

participants (1)