Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 2fb3b1ba by Apoorv Ingle at 2025-07-07T00:16:14-05:00 - kill tcl_in_gen_code - It is subsumed by `ErrCtxtStack` which keep tracks of `ErrCtxt` and code ctxt - - - - - 5 changed files: - compiler/GHC/Hs.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Hs.hs ===================================== @@ -38,8 +38,6 @@ module GHC.Hs ( HsModule(..), AnnsModule(..), HsParsedModule(..), XModulePs(..), - SrcCodeCtxt(..), isUserCodeCtxt, isGeneratedCodeCtxt - ) where -- friends: @@ -149,17 +147,3 @@ data HsParsedModule = HsParsedModule { -- the .hi file, so that we can force recompilation if any of -- them change (#3589) } - --- Used in TcLclCtxt.tcl_in_gen_code to mark if the current expression --- is a user generated code or a compiler generated expansion of some user written code -data SrcCodeCtxt - = UserCode - | GeneratedCode SrcCodeOrigin - -isUserCodeCtxt :: SrcCodeCtxt -> Bool -isUserCodeCtxt UserCode = True -isUserCodeCtxt _ = False - -isGeneratedCodeCtxt :: SrcCodeCtxt -> Bool -isGeneratedCodeCtxt UserCode = False -isGeneratedCodeCtxt _ = True ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -189,8 +189,8 @@ tcExprSigma inst rn_expr = do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr ; do_ql <- wantQuickLook rn_fun ; (tc_fun, fun_sigma) <- tcInferAppHead fun - ; code_ctxt <- getSrcCodeCtxt - ; let fun_orig = srcCodeCtxtCtOrigin rn_expr code_ctxt + ; code_orig <- getSrcCodeOrigin + ; let fun_orig = srcCodeOriginCtOrigin rn_expr code_orig ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args ; tc_args <- tcValArgs do_ql rn_fun inst_args ; let tc_expr = rebuildHsApps (tc_fun, fun_ctxt) tc_args @@ -417,8 +417,8 @@ tcApp rn_expr exp_res_ty ; let tc_head = (tc_fun, fun_loc) -- Step 3: Instantiate the function type (taking a quick look at args) ; do_ql <- wantQuickLook rn_fun - ; code_ctxt <- getSrcCodeCtxt - ; let fun_orig = srcCodeCtxtCtOrigin rn_fun code_ctxt + ; code_orig <- getSrcCodeOrigin + ; let fun_orig = srcCodeOriginCtOrigin rn_fun code_orig ; traceTc "tcApp:inferAppHead" $ vcat [ text "tc_fun:" <+> ppr tc_fun , text "fun_sigma:" <+> ppr fun_sigma @@ -857,8 +857,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args -- Rule IARG from Fig 4 of the QL paper: go1 pos acc fun_ty (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args) - = do { let herald | DoStmtOrigin <- fun_orig = ExpectedFunTySyntaxOp fun_orig tc_fun -- cf. RepPolyDoBind.hs - | otherwise = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg) + = do { let herald = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg) ; (wrap, arg_ty, res_ty) <- -- NB: matchActualFunTy does the rep-poly check. -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -21,13 +21,14 @@ module GHC.Tc.Types.LclEnv ( , setLclEnvTypeEnv , modifyLclEnvTcLevel - , getLclEnvSrcCodeCtxt - , setLclEnvSrcCodeCtxt - , setLclCtxtSrcCodeCtxt + , getLclEnvSrcCodeOrigin + , setLclEnvSrcCodeOrigin + , setLclCtxtSrcCodeOrigin , lclEnvInGeneratedCode , addLclEnvErrCtxt + , ErrCtxtStack (..) , ArrowCtxt(..) , ThBindEnv , TcTypeEnv @@ -35,7 +36,7 @@ module GHC.Tc.Types.LclEnv ( import GHC.Prelude -import GHC.Hs ( SrcCodeCtxt (..), isGeneratedCodeCtxt ) +import GHC.Hs ( SrcCodeOrigin ) import GHC.Tc.Utils.TcType ( TcLevel ) import GHC.Tc.Errors.Types ( TcRnMessage ) @@ -90,11 +91,29 @@ data TcLclEnv -- Changes as we move inside an expression tcl_errs :: TcRef (Messages TcRnMessage) -- Place to accumulate diagnostics } + +data ErrCtxtStack + = UserCodeCtxt {err_ctxt :: [ErrCtxt]} + | GeneratedCodeCtxt { src_code_origin :: SrcCodeOrigin + , err_ctxt :: [ErrCtxt] } + +isGeneratedCodeCtxt :: ErrCtxtStack -> Bool +isGeneratedCodeCtxt UserCodeCtxt{} = False +isGeneratedCodeCtxt _ = True + +get_src_code_origin :: ErrCtxtStack -> Maybe SrcCodeOrigin +get_src_code_origin (UserCodeCtxt{}) = Nothing +get_src_code_origin es = Just $ src_code_origin es + +modify_err_ctxt_stack :: ([ErrCtxt] -> [ErrCtxt]) -> ErrCtxtStack -> ErrCtxtStack +modify_err_ctxt_stack f (UserCodeCtxt e) = UserCodeCtxt (f e) +modify_err_ctxt_stack _ c = c -- any updates on the err context in generated context should be ignored + + data TcLclCtxt = TcLclCtxt { tcl_loc :: RealSrcSpan, -- Source span - tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_in_gen_code :: SrcCodeCtxt, + tcl_ctxt :: ErrCtxtStack, tcl_tclvl :: TcLevel, tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, -- and for tidying type @@ -159,28 +178,28 @@ getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc . tcl_lcl_ctxt getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt] -getLclEnvErrCtxt = tcl_ctxt . tcl_lcl_ctxt +getLclEnvErrCtxt = err_ctxt . tcl_ctxt . tcl_lcl_ctxt setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv -setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt }) +setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ _ -> ctxt) (tcl_ctxt env) }) addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -addLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt : (tcl_ctxt env) }) +addLclEnvErrCtxt ec = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ctxt -> ec : ctxt) (tcl_ctxt env) }) -getLclEnvSrcCodeCtxt :: TcLclEnv -> SrcCodeCtxt -getLclEnvSrcCodeCtxt = tcl_in_gen_code . tcl_lcl_ctxt +getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin +getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_ctxt . tcl_lcl_ctxt -lclEnvInGeneratedCode :: TcLclEnv -> Bool -lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt +setLclEnvSrcCodeOrigin :: SrcCodeOrigin -> TcLclEnv -> TcLclEnv +setLclEnvSrcCodeOrigin o = modifyLclCtxt (setLclCtxtSrcCodeOrigin o) -lclCtxtInGeneratedCode :: TcLclCtxt -> Bool -lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_in_gen_code +setLclCtxtSrcCodeOrigin :: SrcCodeOrigin -> TcLclCtxt -> TcLclCtxt +setLclCtxtSrcCodeOrigin o ctxt = ctxt { tcl_ctxt = GeneratedCodeCtxt o (err_ctxt $ tcl_ctxt ctxt) } -setLclCtxtSrcCodeCtxt :: SrcCodeCtxt -> TcLclCtxt -> TcLclCtxt -setLclCtxtSrcCodeCtxt userOrGen env = env { tcl_in_gen_code = userOrGen } +lclCtxtInGeneratedCode :: TcLclCtxt -> Bool +lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_ctxt -setLclEnvSrcCodeCtxt :: SrcCodeCtxt -> TcLclEnv -> TcLclEnv -setLclEnvSrcCodeCtxt userOrGen = modifyLclCtxt (\ctxt -> setLclCtxtSrcCodeCtxt userOrGen ctxt) +lclEnvInGeneratedCode :: TcLclEnv -> Bool +lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt getLclEnvBinderStack :: TcLclEnv -> TcBinderStack getLclEnvBinderStack = tcl_bndrs . tcl_lcl_ctxt ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -19,7 +19,7 @@ module GHC.Tc.Types.Origin ( -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, - srcCodeCtxtCtOrigin, + srcCodeOriginCtOrigin, isVisibleOrigin, toInvisibleOrigin, pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin, isWantedSuperclassOrigin, @@ -653,6 +653,7 @@ data CtOrigin Type -- the instantiated type of the method | AmbiguityCheckOrigin UserTypeCtxt | ImplicitLiftOrigin HsImplicitLiftSplice + | ExpansionOrigin SrcCodeOrigin -- This is due to an expansion of the original thing given by SrcCodeOrigin data NonLinearPatternReason = LazyPatternReason @@ -764,18 +765,13 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] -exprCtOrigin (XExpr (ExpandedThingRn o _)) = srcCodeOriginCtOrigin o +exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) -srcCodeOriginCtOrigin :: SrcCodeOrigin -> CtOrigin -srcCodeOriginCtOrigin (OrigExpr e) = exprCtOrigin e -srcCodeOriginCtOrigin (OrigStmt{}) = DoStmtOrigin -srcCodeOriginCtOrigin (OrigPat p) = DoPatOrigin p - -srcCodeCtxtCtOrigin :: HsExpr GhcRn -> SrcCodeCtxt -> CtOrigin -srcCodeCtxtCtOrigin e UserCode = exprCtOrigin e -srcCodeCtxtCtOrigin _ (GeneratedCode e) = srcCodeOriginCtOrigin e +srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe SrcCodeOrigin -> CtOrigin +srcCodeOriginCtOrigin e Nothing = exprCtOrigin e +srcCodeOriginCtOrigin _ (Just e) = ExpansionOrigin e -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin @@ -801,6 +797,14 @@ pprCtOrigin :: CtOrigin -> SDoc pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk +pprCtOrigin (ExpansionOrigin o) + = ctoHerald <+> what + where what :: SDoc + what = case o of + OrigStmt{} -> text "a do statement" + OrigExpr e -> text "an expression" <+> ppr e + OrigPat p -> text "a pattern" <+> ppr p + pprCtOrigin (GivenSCOrigin sk d blk) = vcat [ ctoHerald <+> pprSkolInfo sk , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ] @@ -984,6 +988,10 @@ pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance" pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check" pprCtO (ImpedanceMatching {}) = text "combining required constraints" pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)] +pprCtO (ExpansionOrigin (OrigPat p)) = hsep [text "a pattern" <+> quotes (ppr p)] +pprCtO (ExpansionOrigin (OrigStmt{})) = text "a do statement" +pprCtO (ExpansionOrigin (OrigExpr{})) = text "an expression" + pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear") ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -58,7 +58,7 @@ module GHC.Tc.Utils.Monad( addDependentFiles, -- * Error management - getSrcCodeCtxt, + getSrcCodeOrigin, getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, setInGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, @@ -400,8 +400,7 @@ initTcWithGbl hsc_env gbl_env loc do_this tcl_lcl_ctxt = TcLclCtxt { tcl_loc = loc, -- tcl_loc should be over-ridden very soon! - tcl_in_gen_code = UserCode, - tcl_ctxt = [], + tcl_ctxt = UserCodeCtxt [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topLevel, tcl_th_bndrs = emptyNameEnv, @@ -978,21 +977,21 @@ setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -- See Note [Error contexts in generated code] -- for the tcl_in_gen_code manipulation setSrcSpan (RealSrcSpan loc _) thing_inside - = updLclCtxt (\env -> env { tcl_loc = loc, tcl_in_gen_code = UserCode }) + = updLclCtxt (\env -> env { tcl_loc = loc, tcl_ctxt = UserCodeCtxt (err_ctxt $ tcl_ctxt env)}) thing_inside setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside -getSrcCodeCtxt :: TcRn SrcCodeCtxt -getSrcCodeCtxt = getLclEnvSrcCodeCtxt <$> getLclEnv +getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin) +getSrcCodeOrigin = getLclEnvSrcCodeOrigin <$> getLclEnv -- | Mark the inner computation as being done inside generated code. -- -- See Note [Error contexts in generated code] setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a -setInGeneratedCode scOrig thing_inside = - updLclCtxt (setLclCtxtSrcCodeCtxt (GeneratedCode scOrig)) thing_inside +setInGeneratedCode sco thing_inside = + updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fb3b1ba81aa2bd6d2b2985139638db4... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fb3b1ba81aa2bd6d2b2985139638db4... You're receiving this email because of your account on gitlab.haskell.org.