Apoorv Ingle pushed to branch wip/ani/kill-popErrCtxt at Glasgow Haskell Compiler / GHC Commits: 58ba3ecc by Apoorv Ingle at 2025-09-22T18:00:08-05:00 some progress with addArgCtxt - - - - - 9 changed files: - compiler/GHC/Tc/Errors/Ppr.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/LclEnv.hs - compiler/GHC/Tc/Utils/Monad.hs - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr Changes: ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7238,10 +7238,6 @@ pprTyConInstFlavour pprErrCtxtMsg :: ErrCtxtMsg -> SDoc pprErrCtxtMsg = \case ExprCtxt expr - | XExpr (ExpandedThingRn (OrigStmt (L _ stmt) flav) _) <- expr - -> hang (text "In a stmt of" <+> pprAStmtContext @(LIdP GhcRn) (HsDoStmt flav) <> colon) - 2 (ppr_stmt stmt) - | otherwise -> hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr)) ThetaCtxt ctxt theta -> ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -396,8 +396,10 @@ tcApp :: HsExpr GhcRn tcApp rn_expr exp_res_ty = do { -- Step 1: Split the application chain (fun@(rn_fun, fun_loc), rn_args) <- splitHsApps rn_expr + ; inGenCode <- inGeneratedCode ; traceTc "tcApp {" $ - vcat [ text "rn_expr:" <+> ppr rn_expr + vcat [ text "generated? " <+> ppr inGenCode + , text "rn_expr:" <+> ppr rn_expr , text "rn_fun:" <+> ppr rn_fun , text "fun_loc:" <+> ppr fun_loc , text "rn_args:" <+> ppr rn_args ] @@ -580,7 +582,7 @@ tcValArg do_ql _ _ (EWrap (EHsWrap w)) = do { whenQL do_ql $ qlMonoHsWrapper w -- qlMonoHsWrapper: see Note [Monomorphise instantiation variables] tcValArg _ _ _ (EWrap ew) = return (EWrap ew) -tcValArg do_ql pos fun (EValArg { ea_loc_span = ctxt +tcValArg do_ql pos fun (EValArg { ea_loc_span = lspan , ea_arg = larg@(L arg_loc arg) , ea_arg_ty = sc_arg_ty }) = addArgCtxt pos fun larg $ @@ -597,7 +599,7 @@ tcValArg do_ql pos fun (EValArg { ea_loc_span = ctxt DoQL -> liftZonkM $ zonkScaledTcType sc_arg_ty NoQL -> return sc_arg_ty ; traceTc "tcValArg {" $ - vcat [ text "ctxt:" <+> ppr ctxt + vcat [ text "lspan:" <+> ppr lspan , text "sigma_type" <+> ppr (mkCheckExpType exp_arg_ty) , text "arg:" <+> ppr larg ] @@ -608,13 +610,13 @@ tcValArg do_ql pos fun (EValArg { ea_loc_span = ctxt tcPolyExpr arg (mkCheckExpType exp_arg_ty) ; traceTc "tcValArg" $ vcat [ ppr arg' , text "}" ] - ; return (EValArg { ea_loc_span = ctxt + ; return (EValArg { ea_loc_span = lspan , ea_arg = L arg_loc arg' , ea_arg_ty = noExtField }) } tcValArg _ pos fun (EValArgQL { eaql_wanted = wanted - , eaql_loc_span = ctxt + , eaql_loc_span = lspan , eaql_arg_ty = sc_arg_ty , eaql_larg = larg@(L arg_loc rn_expr) , eaql_tc_fun = tc_head @@ -659,7 +661,7 @@ tcValArg _ pos fun (EValArgQL { ; traceTc "tcEValArgQL }" $ vcat [ text "app_res_rho:" <+> ppr app_res_rho ] - ; return (EValArg { ea_loc_span = ctxt + ; return (EValArg { ea_loc_span = lspan , ea_arg = L arg_loc (mkHsWrap wrap arg') , ea_arg_ty = noExtField }) } @@ -931,11 +933,12 @@ looks_like_type_arg _ = False addArgCtxt :: Int -> HsExpr GhcRn -> LHsExpr GhcRn -> TcM a -> TcM a -- There are 2 cases: --- 1. In the normal case, we add an informative context --- "In the third argument of f, namely blah" --- 2. If we are deep inside generated code (<=> `isGeneratedCode` is `True`) --- "In the expression: arg" --- If the arg is also a generated thing, i.e. `arg_loc` is `generatedSrcSpan`, we would print nothing. +-- 1. In the normal case, we add an informative context (<=> `isGeneratedCode` is `False`) +-- "In the third argument of f, namely blah" +-- 2. If we are inside generated code (<=> `isGeneratedCode` 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 -- 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 (L arg_loc arg) thing_inside @@ -944,12 +947,24 @@ addArgCtxt arg_no fun (L arg_loc arg) thing_inside , text "arg: " <+> ppr arg , text "arg_loc" <+> ppr arg_loc]) ; if in_generated_code - then do setSrcSpanA arg_loc $ - addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated + then updCtxtForArg (locA 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 + + {- ********************************************************************* * * ===================================== 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 becuase of statement loc + [ wrapNoSpan $ unLoc e -- Span is set because of statement loc , expand_stmts_expr ] return $ L loc (mkExpandedStmt stmt doFlavour expansion) ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -662,10 +662,11 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr res_ty = assert (notNull rbnds) $ do { -- Expand the record update. See Note [Record Updates]. + ; (ds_expr, ds_res_ty, err_msg) <- expandRecordUpd record_expr possible_parents rbnds res_ty ; addErrCtxt err_msg $ - setInGeneratedCode (OrigExpr expr) $ + ; setInGeneratedCode (OrigExpr expr) $ do { -- Typecheck the expanded expression. expr' <- tcExpr ds_expr (Check ds_res_ty) -- NB: it's important to use ds_res_ty and not res_ty here. ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -217,7 +217,7 @@ type family XPass (p :: TcPass) where mkEValArg :: SrcSpan -> LHsExpr GhcRn -> HsExprArg 'TcpRn mkEValArg src_loc e = EValArg { ea_arg = e, ea_loc_span = src_loc - , ea_arg_ty = noExtField } + , ea_arg_ty = noExtField } mkETypeArg :: SrcSpan -> LHsWcType GhcRn -> HsExprArg 'TcpRn mkETypeArg src_loc hs_ty = @@ -244,18 +244,18 @@ splitHsApps e = go e noSrcSpan [] go :: HsExpr GhcRn -> SrcSpan -> [HsExprArg 'TcpRn] -> TcM ((HsExpr GhcRn, SrcSpan), [HsExprArg 'TcpRn]) -- Modify the SrcSpan as we walk inwards, so it describes the next argument - go (HsPar _ (L l fun)) sloc args = go fun (locA l) (EWrap (EPar sloc) : args) - go (HsPragE _ p (L l fun)) sloc args = go fun (locA l) (EPrag sloc p : args) - go (HsAppType _ (L l fun) ty) sloc args = go fun (locA l) (mkETypeArg sloc ty : args) - go (HsApp _ (L l fun) arg) sloc args = go fun (locA l) (mkEValArg sloc arg : args) + go (HsPar _ (L l fun)) lspan args = go fun (locA l) (EWrap (EPar lspan) : args) + go (HsPragE _ p (L l fun)) lspan args = go fun (locA l) (EPrag lspan p : args) + go (HsAppType _ (L l fun) ty) lspan args = go fun (locA l) (mkETypeArg lspan ty : args) + go (HsApp _ (L l fun) arg) lspan args = go fun (locA l) (mkEValArg lspan arg : args) -- See Note [Looking through Template Haskell splices in splitHsApps] go e@(HsUntypedSplice splice_res splice) _ args = do { fun <- getUntypedSpliceBody splice_res - ; go fun sloc' (EWrap (EExpand e) : args) } + ; go fun lspan' (EWrap (EExpand e) : args) } where - sloc' :: SrcSpan - sloc' = case splice of + lspan' :: SrcSpan + lspan' = case splice of HsUntypedSpliceExpr _ (L l _) -> locA l -- l :: SrcAnn AnnListItem HsQuasiQuote _ _ (L l _) -> locA l -- l :: SrcAnn NoEpAnns (XUntypedSplice (HsImplicitLiftSplice _ _ _ (L l _))) -> locA l @@ -269,11 +269,11 @@ splitHsApps e = go e noSrcSpan [] -- and its hard to say exactly what that is : EWrap (EExpand e) : args ) - go (XExpr (PopErrCtxt fun)) sloc args = go fun sloc args + go (XExpr (PopErrCtxt fun)) lspan args = go fun lspan args -- look through PopErrCtxt (cf. T17594f) we do not want to lose the opportunity of calling tcEValArgQL -- unlike HsPar, it is okay to forget about the PopErrCtxts as it does not persist over in GhcTc land - go e sloc args = pure ((e, sloc), args) + go e lspan args = pure ((e, lspan), args) -- | Rebuild an application: takes a type-checked application head @@ -1109,4 +1109,6 @@ 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 _ -> addErrCtxt (ExprCtxt e) thing_inside -- no op in generated code ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -26,6 +26,7 @@ module GHC.Tc.Types.LclEnv ( , setLclCtxtSrcCodeOrigin , lclEnvInGeneratedCode , setLclCtxtInGenCode + , setLclCtxtInUserCode , addLclEnvErrCtxt @@ -210,6 +211,9 @@ setLclEnvSrcCodeOrigin o = modifyLclCtxt (setLclCtxtSrcCodeOrigin o) setLclCtxtInGenCode :: TcLclCtxt -> TcLclCtxt setLclCtxtInGenCode lclCtxt = lclCtxt { tcl_in_gen_code = True } +setLclCtxtInUserCode :: TcLclCtxt -> TcLclCtxt +setLclCtxtInUserCode lclCtxt = lclCtxt { tcl_in_gen_code = False } + -- See Note [ErrCtxt Stack Manipulation] setLclCtxtSrcCodeOrigin :: SrcCodeOrigin -> TcLclCtxt -> TcLclCtxt setLclCtxtSrcCodeOrigin o lclCtxt ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -60,7 +60,7 @@ module GHC.Tc.Utils.Monad( -- * Error management getSrcCodeOrigin, getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, - inGeneratedCode, setInGeneratedCode, + inGeneratedCode, setInGeneratedCode, setInUserCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, @@ -991,7 +991,12 @@ setSrcSpan (UnhelpfulSpan _) thing_inside = updLclCtxt setLclCtxtInGenCode thing_inside getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin) -getSrcCodeOrigin = getLclEnvSrcCodeOrigin <$> getLclEnv +getSrcCodeOrigin = + do inGenCode <- inGeneratedCode + if inGenCode + then getLclEnvSrcCodeOrigin <$> getLclEnv + else return Nothing + -- | Mark the inner computation as being done inside generated code. -- @@ -1002,6 +1007,9 @@ setInGeneratedCode sco thing_inside = updLclCtxt setLclCtxtInGenCode $ updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside +setInUserCode :: TcRn a -> TcRn a +setInUserCode = updLclCtxt setLclCtxtInUserCode + setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) ===================================== testsuite/tests/typecheck/should_fail/DoExpansion1.stderr ===================================== @@ -22,7 +22,7 @@ DoExpansion1.hs:15:54: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefaul DoExpansion1.hs:19:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)] • No instance for ‘Num String’ arising from the literal ‘1’ • In the first argument of ‘putStrLn’, namely ‘1’ - In the expression: putStrLn 1 + In a stmt of a 'do' block: putStrLn 1 In the expression: do putStrLn 1 putStrLn "r2" @@ -31,7 +31,7 @@ DoExpansion1.hs:19:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefaul DoExpansion1.hs:25:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)] • No instance for ‘Num String’ arising from the literal ‘2’ • In the first argument of ‘putStrLn’, namely ‘2’ - In the expression: putStrLn 2 + In a stmt of a 'do' block: putStrLn 2 In the expression: do putStrLn "r1" putStrLn 2 ===================================== testsuite/tests/typecheck/should_fail/DoExpansion2.stderr ===================================== @@ -57,9 +57,7 @@ DoExpansion2.hs:34:22: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefaul • The function ‘getVal’ is applied to two visible arguments, but its type ‘Int -> IO String’ has only one In the expression: getVal 3 4 - In the expression: - do Just x <- getVal 3 4 - return x + In a stmt of a 'do' block: Just x <- getVal 3 4 DoExpansion2.hs:39:19: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)] • Couldn't match type ‘[Char]’ with ‘Int’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58ba3ecc69de24e5aacc803a1fb51907... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58ba3ecc69de24e5aacc803a1fb51907... You're receiving this email because of your account on gitlab.haskell.org.