Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 7d2a15c1 by Apoorv Ingle at 2026-03-19T16:09:36-05:00 remove srcCodeOrigin references, add some WIP flag - - - - - 7 changed files: - 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/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -1943,7 +1943,7 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ do { ((rn_fun_arg, fun_lspan_arg), rn_args) <- splitHsApps arg -- Step 1: get the type of the head of the argument - ; (fun_ue, mb_fun_ty) <- (tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg) + ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg -- tcCollectingUsage: the use of an Id at the head generates usage-info -- See the call to `tcEmitBindingUsage` in `check_local_id`. So we must -- capture and save it in the `EValArgQL`. See (QLA6) in @@ -2020,9 +2020,9 @@ mk_origin fun_lspan rn_fun = return $ exprCtOrigin rn_fun | otherwise -- if the location is generated, -- the best we can do is to approximate by looking on top of the error message stack - = do { code_orig <- getSrcCodeOrigin + = do { code_orig <- getHsCtxt ; traceTc "mk_origin" (pprHsCtxt code_orig) - ; return $ srcCodeOriginCtOrigin code_orig + ; return $ hsCtxtCtOrigin code_orig } ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -448,7 +448,7 @@ It stores the original statement (with location) and the expanded expression of the error context stack which contains the error message for the previous statement: eg. "In the stmt of a do block: e1". This popping is implicitly done when we push the error context message for the next statment. - See Note [ErrCtxtStack Manipulation] and `LclEnv.setLclCtxtSrcCodeOrigin` + See Note [ErrCtxtStack Manipulation] and `LclEnv.setLclCtxtHsCtxt` Sans the popping business for error context stack, if there were to be a type error in `e2`, we would get a spurious and confusing error message ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -677,6 +677,7 @@ tcExpr expr@(RecordCon { rcon_con = L loc qcon@(WithUserRdr _ con_name) -- in the renamer. See Note [Overview of record dot syntax] in -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here -- and panic otherwise. +-- WIP: To be fixed soon expandRecordUpd needs to return HsExpansion and not a separate ds_res_ty tcExpr expr@(RecordUpd { rupd_expr = record_expr , rupd_flds = RegularRecUpdFields @@ -1862,14 +1863,3 @@ checkMissingFields con_like rbinds arg_tys field_strs = conLikeImplBangs con_like fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds - - --- Expands the expression on the fly --- See Note [Handling overloaded and rebindable constructs] --- See Note [Typechecking by expansion: overview] -tcExpandExpr :: HsExpr GhcRn -> TcM (HsExpr GhcRn) -tcExpandExpr orig_expr@(HsDo _ flav (L _ stmts)) - = do { expanded_expr <- expandDoStmts flav stmts - ; return (mkExpandedLExpr orig_expr expanded_expr) } - -tcExpandExpr e = return e ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -467,7 +467,7 @@ tcInferAppHead_maybe fun = case fun of -- visible type applications in the argument. -- c.f. T19167 (\ (e, ds_flag, ty) -> (mkExpandedTc o (L loc e), ds_flag, ty)) <$> - tcExprSigma False (errCtxtCtOrigin o) e + tcExprSigma False (hsCtxtCtOrigin o) e ) _ -> return Nothing ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -21,9 +21,9 @@ module GHC.Tc.Types.LclEnv ( , setLclEnvTypeEnv , modifyLclEnvTcLevel - , getLclEnvSrcCodeOrigin - , setLclEnvSrcCodeOrigin - , setLclCtxtSrcCodeOrigin + , getLclEnvHsCtxt + , setLclEnvHsCtxt + , setLclCtxtHsCtxt , lclEnvInGeneratedCode , addLclEnvErrCtxt @@ -110,7 +110,7 @@ This data structure keeps track of two things: In the current design, if the top of the ErrCtxtStack is an ExpansionCodeCtxt i.e. we are currently typechecking a compiler generated expression, and we encounter an XExpr, then we _replace_ the top of the stack with the new XExpr. Otherwise, we -push the new expression error message on top of the stack. cf. `LclEnv.setLclCtxtSrcCodeOrigin` +push the new expression error message on top of the stack. cf. `LclEnv.setLclCtxtHsCtxt` -} @@ -119,9 +119,9 @@ push the new expression error message on top of the stack. cf. `LclEnv.setLclCtx type ErrCtxtStack = [ErrCtxt] -- | Get the top of the error message stack -get_src_code_origin :: ErrCtxtStack -> HsCtxt -get_src_code_origin (e : _) = e -get_src_code_origin _ = error "get_src_code_origin: oops! Empty error message stack" +get_err_ctxt_stack_head :: ErrCtxtStack -> HsCtxt +get_err_ctxt_stack_head (e : _) = e +get_err_ctxt_stack_head _ = error "get_err_ctxt_stack_head: oops! Empty error message stack" data TcLclCtxt = TcLclCtxt { @@ -199,17 +199,17 @@ setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt }) -- See Note [ErrCtxtStack Manipulation] addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -addLclEnvErrCtxt ec = setLclEnvSrcCodeOrigin ec +addLclEnvErrCtxt ec = setLclEnvHsCtxt ec -getLclEnvSrcCodeOrigin :: TcLclEnv -> HsCtxt -getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_err_ctxt . tcl_lcl_ctxt +getLclEnvHsCtxt :: TcLclEnv -> HsCtxt +getLclEnvHsCtxt = get_err_ctxt_stack_head . tcl_err_ctxt . tcl_lcl_ctxt -setLclEnvSrcCodeOrigin :: ErrCtxt -> TcLclEnv -> TcLclEnv -setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec) +setLclEnvHsCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv +setLclEnvHsCtxt ec = modifyLclCtxt (setLclCtxtHsCtxt ec) -- See Note [ErrCtxtStack Manipulation] -setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt -setLclCtxtSrcCodeOrigin ec lclCtxt +setLclCtxtHsCtxt :: ErrCtxt -> TcLclCtxt -> TcLclCtxt +setLclCtxtHsCtxt ec lclCtxt -- never stack 2 statement error contexts on top of each other | StmtErrCtxt{} : ecs <- tcl_err_ctxt lclCtxt , StmtErrCtxt{} <- ec ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -9,7 +9,7 @@ module GHC.Tc.Types.Origin ( -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, - srcCodeOriginCtOrigin, errCtxtCtOrigin, + hsCtxtCtOrigin, invisibleOrigin_maybe, isVisibleOrigin, toInvisibleOrigin, pprCtOrigin, pprCtOriginBriefly, isGivenOrigin, defaultReprEqOrigins, isWantedSuperclassOrigin, @@ -625,20 +625,16 @@ exprCtOrigin (HsIf {}) = IfThenElseOrigin exprCtOrigin (HsProjection _ p) = RecordFieldProjectionOrigin (FieldLabelStrings $ fmap noLocA p) exprCtOrigin (RecordUpd{}) = RecordUpdOrigin exprCtOrigin (HsGetField _ _ f) = GetFieldOrigin (fmap field_label $ dfoLabel (unLoc f)) -exprCtOrigin (XExpr (ExpandedThingRn (HSE o _))) = errCtxtCtOrigin o +exprCtOrigin (XExpr (ExpandedThingRn (HSE o _))) = hsCtxtCtOrigin o exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) -srcCodeOriginCtOrigin :: HsCtxt -> CtOrigin -srcCodeOriginCtOrigin = errCtxtCtOrigin - -errCtxtCtOrigin :: HsCtxt -> CtOrigin -errCtxtCtOrigin (ExprCtxt e) = exprCtOrigin e -errCtxtCtOrigin (FunAppCtxt (FunAppCtxtExpr _ e) _) = exprCtOrigin e -errCtxtCtOrigin (StmtErrCtxt{}) = DoStmtOrigin -errCtxtCtOrigin (StmtErrCtxtPat p) = DoPatOrigin p -errCtxtCtOrigin (RecordUpdCtxt{}) = RecordUpdOrigin -errCtxtCtOrigin _ = Shouldn'tHappenOrigin "errCtxtCtOrigin" - +hsCtxtCtOrigin :: HsCtxt -> CtOrigin +hsCtxtCtOrigin (ExprCtxt e) = exprCtOrigin e +hsCtxtCtOrigin (FunAppCtxt (FunAppCtxtExpr _ e) _) = exprCtOrigin e +hsCtxtCtOrigin (StmtErrCtxt{}) = DoStmtOrigin +hsCtxtCtOrigin (StmtErrCtxtPat p) = DoPatOrigin p +hsCtxtCtOrigin (RecordUpdCtxt{}) = RecordUpdOrigin +hsCtxtCtOrigin _ = Shouldn'tHappenOrigin "hsCtxtCtOrigin" -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -61,7 +61,7 @@ module GHC.Tc.Utils.Monad( addDependentFiles, addDependentDirectories, -- * Error management - getSrcCodeOrigin, + getHsCtxt, getSrcSpanM, getRealSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, @@ -1094,8 +1094,8 @@ setSrcSpan (GeneratedSrcSpan{}) thing_inside setSrcSpan _ thing_inside = thing_inside -getSrcCodeOrigin :: TcRn HsCtxt -getSrcCodeOrigin = getLclEnvSrcCodeOrigin <$> getLclEnv +getHsCtxt :: TcRn HsCtxt +getHsCtxt = getLclEnvHsCtxt <$> getLclEnv setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7d2a15c1226cfa12c0df3b011d91d73a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7d2a15c1226cfa12c0df3b011d91d73a... You're receiving this email because of your account on gitlab.haskell.org.