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
3 changed files:
Changes:
| ... | ... | @@ -32,8 +32,7 @@ import GHC.Tc.Gen.HsType |
| 32 | 32 | import GHC.Tc.Utils.Concrete ( unifyConcrete, idConcreteTvs )
|
| 33 | 33 | import GHC.Tc.Utils.TcMType
|
| 34 | 34 | import GHC.Tc.Types.Evidence
|
| 35 | -import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..), ErrCtxt (..), CodeSrcFlag (..))
|
|
| 36 | -import GHC.Tc.Errors.Ppr (pprErrCtxtMsg)
|
|
| 35 | +import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..) )
|
|
| 37 | 36 | import GHC.Tc.Types.Origin
|
| 38 | 37 | import GHC.Tc.Utils.TcType as TcType
|
| 39 | 38 | import GHC.Tc.Utils.Concrete( hasFixedRuntimeRep_syntactic )
|
| ... | ... | @@ -939,43 +938,22 @@ looks_like_type_arg _ = False |
| 939 | 938 | addArgCtxt :: Int -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn
|
| 940 | 939 | -> TcM a -> TcM a
|
| 941 | 940 | -- There are 2 cases:
|
| 942 | --- 1. In the normal case, we add an informative context (<=> `inGeneratedCode` is `False`)
|
|
| 941 | +-- 1. In the normal case, we add an informative context
|
|
| 942 | +-- (<=> location span of f or head of application chain is user located)
|
|
| 943 | 943 | -- "In the third argument of f, namely blah"
|
| 944 | --- 2. If we are inside generated code (<=> `inGeneratedCode` is `True`)
|
|
| 945 | --- (i) If arg_loc is generated do nothing to to LclEnv/LclCtxt
|
|
| 946 | --- (ii) If arg_loc is Unhelpful UnhelpfulNoLocationInfo set `tcl_in_gen_code` to `True`
|
|
| 947 | --- (iii) if arg_loc is RealSrcLoc then update tcl_loc and add "In the expression: arg" to ErrCtxtStack
|
|
| 944 | +-- 2. If head of the application chain is generated
|
|
| 945 | +-- "In the expression: arg"
|
|
| 946 | + |
|
| 948 | 947 | -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
|
| 949 | 948 | -- See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do
|
| 950 | -addArgCtxt arg_no (fun, fun_lspan) (L arg_loc arg) thing_inside
|
|
| 951 | - = do { in_generated_code <- inGeneratedCode
|
|
| 952 | - ; err_ctx <- getErrCtxt
|
|
| 953 | - ; env0 <- liftZonkM tcInitTidyEnv
|
|
| 954 | - ; err_ctx_msg <- mkErrCtxt env0 err_ctx
|
|
| 955 | - ; traceTc "addArgCtxt" (vcat [ text "generated:" <+> ppr in_generated_code
|
|
| 956 | - , text "arg: " <+> ppr (arg, arg_no)
|
|
| 957 | - , text "arg_loc:" <+> ppr arg_loc
|
|
| 958 | - , text "fun:" <+> ppr fun
|
|
| 959 | - , text "fun_lspan" <+> ppr fun_lspan
|
|
| 960 | - , text "err_ctx" <+> vcat (fmap (\ (x, y) ->
|
|
| 961 | - case x of
|
|
| 962 | - MkErrCtxt (ExpansionCodeCtxt{}) _ -> text "<EXPN>" <+> pprErrCtxtMsg y
|
|
| 963 | - _ -> text "<USER>" <+> pprErrCtxtMsg y)
|
|
| 964 | - (take 4 (zip err_ctx err_ctx_msg)))
|
|
| 965 | - ])
|
|
| 966 | - ; if not (isGeneratedSrcSpan fun_lspan)
|
|
| 967 | - then setSrcSpanA arg_loc $
|
|
| 968 | - addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $
|
|
| 969 | - thing_inside
|
|
| 970 | - else updCtxtForArg (L arg_loc arg) $
|
|
| 971 | - thing_inside
|
|
| 972 | - }
|
|
| 973 | - where
|
|
| 974 | - updCtxtForArg :: LHsExpr GhcRn -> TcRn a -> TcRn a
|
|
| 975 | - updCtxtForArg e@(L lspan _) thing_inside
|
|
| 976 | - = do setSrcSpan (locA lspan) $
|
|
| 977 | - addLExprCtxt e $ -- addLExpr is no op for non-user located exprs
|
|
| 978 | - thing_inside
|
|
| 949 | +addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside
|
|
| 950 | + | isGoodSrcSpan app_head_lspan
|
|
| 951 | + = setSrcSpanA arg_loc $
|
|
| 952 | + addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $
|
|
| 953 | + thing_inside
|
|
| 954 | + | otherwise
|
|
| 955 | + = addLExprCtxt (locA arg_loc) arg $
|
|
| 956 | + thing_inside
|
|
| 979 | 957 | |
| 980 | 958 | |
| 981 | 959 |
| ... | ... | @@ -121,8 +121,7 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType |
| 121 | 121 | -> TcM (LHsExpr GhcTc)
|
| 122 | 122 | |
| 123 | 123 | tcPolyLExpr (L loc expr) res_ty
|
| 124 | - = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
|
|
| 125 | - addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code]
|
|
| 124 | + = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code]
|
|
| 126 | 125 | do { expr' <- tcPolyExpr expr res_ty
|
| 127 | 126 | ; return (L loc expr') }
|
| 128 | 127 | |
| ... | ... | @@ -240,8 +239,7 @@ tcInferRhoNC = tcInferExprNC IIF_DeepRho |
| 240 | 239 | |
| 241 | 240 | tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
|
| 242 | 241 | tcInferExpr iif (L loc expr)
|
| 243 | - = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
|
|
| 244 | - addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code]
|
|
| 242 | + = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code]
|
|
| 245 | 243 | do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr)
|
| 246 | 244 | ; return (L loc expr', rho) }
|
| 247 | 245 | |
| ... | ... | @@ -267,8 +265,7 @@ tcMonoLExpr, tcMonoLExprNC |
| 267 | 265 | -> TcM (LHsExpr GhcTc)
|
| 268 | 266 | |
| 269 | 267 | tcMonoLExpr (L loc expr) res_ty
|
| 270 | - = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
|
|
| 271 | - addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code]
|
|
| 268 | + = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code]
|
|
| 272 | 269 | do { expr' <- tcExpr expr res_ty
|
| 273 | 270 | ; return (L loc expr') }
|
| 274 | 271 |
| ... | ... | @@ -26,7 +26,7 @@ module GHC.Tc.Gen.Head |
| 26 | 26 | , nonBidirectionalErr
|
| 27 | 27 | |
| 28 | 28 | , pprArgInst
|
| 29 | - , addExprCtxt, addLExprCtxt, addFunResCtxt ) where
|
|
| 29 | + , addLExprCtxt, addFunResCtxt ) where
|
|
| 30 | 30 | |
| 31 | 31 | import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )
|
| 32 | 32 | import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody )
|
| ... | ... | @@ -1101,8 +1101,9 @@ mis-match in the number of value arguments. |
| 1101 | 1101 | * *
|
| 1102 | 1102 | ********************************************************************* -}
|
| 1103 | 1103 | |
| 1104 | -addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
|
|
| 1105 | -addExprCtxt e thing_inside
|
|
| 1104 | +-- | !Caution!: Users should not call add_expr_ctxt, they ought to use addLExprCtxt
|
|
| 1105 | +add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a
|
|
| 1106 | +add_expr_ctxt e thing_inside
|
|
| 1106 | 1107 | = case e of
|
| 1107 | 1108 | HsHole _ -> thing_inside
|
| 1108 | 1109 | -- The HsHole special case addresses situations like
|
| ... | ... | @@ -1117,12 +1118,12 @@ addExprCtxt e thing_inside |
| 1117 | 1118 | _ -> addErrCtxt (ExprCtxt e) thing_inside -- no op in generated code
|
| 1118 | 1119 | |
| 1119 | 1120 | |
| 1120 | -addLExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a
|
|
| 1121 | -addLExprCtxt (L lspan e) thing_inside
|
|
| 1122 | - | (RealSrcSpan{}) <- locA lspan
|
|
| 1121 | +addLExprCtxt :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a
|
|
| 1122 | +addLExprCtxt lspan e thing_inside
|
|
| 1123 | + | isGoodSrcSpan lspan
|
|
| 1123 | 1124 | , (HsPar _ e') <- e
|
| 1124 | - = addExprCtxt (unLoc e') thing_inside
|
|
| 1125 | - | (RealSrcSpan{}) <- locA lspan
|
|
| 1126 | - = addExprCtxt e thing_inside
|
|
| 1125 | + = setSrcSpan lspan $ add_expr_ctxt (unLoc e') thing_inside
|
|
| 1126 | + | isGoodSrcSpan lspan
|
|
| 1127 | + = setSrcSpan lspan $ add_expr_ctxt e thing_inside
|
|
| 1127 | 1128 | | otherwise
|
| 1128 | 1129 | = thing_inside |