Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: b61531f2 by Apoorv Ingle at 2025-06-23T17:42:30-05:00 make tcl_in_gen_code a SrcCodeCtxt and rename DoOrigin to DoStmtOrigin - - - - - 5 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Types/Origin.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -410,7 +410,6 @@ tcApp rn_expr exp_res_ty vcat [ text "rn_expr:" <+> ppr rn_expr , text "rn_fun:" <+> ppr rn_fun , text "fun_loc:" <+> ppr fun_loc - , text "orig:" <+> ppr fun_orig , text "rn_args:" <+> ppr rn_args ] -- Step 2: Infer the type of `fun`, the head of the application @@ -418,12 +417,13 @@ 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 ; traceTc "tcApp:inferAppHead" $ vcat [ text "tc_fun:" <+> ppr tc_fun , text "fun_sigma:" <+> ppr fun_sigma + , text "fun_origin" <+> ppr fun_orig , text "do_ql:" <+> ppr do_ql] - ; code_ctxt <- getSrcCodeCtxt - ; let fun_orig = srcCodeCtxtCtOrigin rn_fun code_ctxt ; (inst_args, app_res_rho) <- tcInstFun do_ql True fun_orig (tc_fun, rn_fun, fun_loc) fun_sigma rn_args @@ -857,7 +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 | DoOrigin <- fun_orig = ExpectedFunTySyntaxOp fun_orig tc_fun -- cf. RepPolyDoBind.hs + = do { let herald | DoStmtOrigin <- fun_orig = ExpectedFunTySyntaxOp fun_orig tc_fun -- cf. RepPolyDoBind.hs | otherwise = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg) ; (wrap, arg_ty, res_ty) <- -- NB: matchActualFunTy does the rep-poly check. ===================================== compiler/GHC/Tc/Gen/App.hs-boot ===================================== @@ -2,10 +2,9 @@ module GHC.Tc.Gen.App where import GHC.Hs ( HsExpr ) import GHC.Tc.Types ( TcM ) -import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Tc.Utils.TcType ( TcSigmaType ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Prelude (Bool) -tcExprSigma :: Bool -> CtOrigin -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) \ No newline at end of file +tcExprSigma :: Bool -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) \ No newline at end of file ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -114,10 +114,9 @@ tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty) tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) -tcPolyLExpr e@(L loc expr) res_ty - = setUserCodeCtxt (ExprThing e) $ - -- setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - -- addExprCtxt expr $ -- Note [Error contexts in generated code] +tcPolyLExpr (L loc expr) res_ty + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } @@ -747,7 +746,7 @@ tcXExpr (PopErrCtxt e) res_ty addExprCtxt e $ tcExpr e res_ty -tcXExpr xe@(ExpandedThingRn o e) res_ty +tcXExpr (ExpandedThingRn o e) res_ty = mkExpandedTc o <$> -- necessary for breakpoints do setInGeneratedCode o $ tcExpr e res_ty ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -980,7 +980,7 @@ tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside -- in full generality; see #1537 ((rhs_ty, rhs', pat_mult, pat', new_res_ty, thing), bind_op') - <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ + <- tcSyntaxOp DoStmtOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] -> do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ @@ -1004,7 +1004,7 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside = do { -- Deal with rebindable syntax; -- (>>) :: rhs_ty -> new_res_ty -> res_ty ; ((rhs', rhs_ty, new_res_ty, thing), then_op') - <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ + <- tcSyntaxOp DoStmtOrigin then_op [SynRho, SynRho] res_ty $ \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] -> do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) @@ -1031,18 +1031,18 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names -- Unify the types of the "final" Ids (which may -- be polymorphic) with those of "knot-tied" Ids ; (_, ret_op') - <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty] + <- tcSyntaxOp DoStmtOrigin ret_op [synKnownType tup_ty] inner_res_ty $ \_ _ -> return () ; return (ret_op', tup_rets) } ; ((_, mfix_op'), mfix_res_ty) <- tcInfer $ \ exp_ty -> - tcSyntaxOp DoOrigin mfix_op + tcSyntaxOp DoStmtOrigin mfix_op [synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $ \ _ _ -> return () ; ((thing, new_res_ty), bind_op') - <- tcSyntaxOp DoOrigin bind_op + <- tcSyntaxOp DoStmtOrigin bind_op [ synKnownType mfix_res_ty , SynFun (synKnownType tup_ty) SynRho ] res_ty $ @@ -1071,7 +1071,7 @@ tcDoStmt ctxt (XStmtLR (ApplicativeStmt _ pairs mb_join)) res_ty thing_inside Nothing -> (, Nothing) <$> tc_app_stmts res_ty Just join_op -> second Just <$> - (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ + (tcSyntaxOp DoStmtOrigin join_op [SynRho] res_ty $ \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty)) ; return (XStmtLR $ ApplicativeStmt body_ty pairs' mb_join', thing) } @@ -1188,7 +1188,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside goOps _ [] = return [] goOps t_left ((op,t_i,exp_ty) : ops) = do { (_, op') - <- tcSyntaxOp DoOrigin op + <- tcSyntaxOp DoStmtOrigin op [synKnownType t_left, synKnownType exp_ty] t_i $ \ _ _ -> return () ; t_i <- readExpType t_i ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -588,7 +588,7 @@ data CtOrigin -- See Note [Inferring the instance context] -- in GHC.Tc.Deriv.Infer | DefaultOrigin -- Typechecking a default decl - | DoOrigin -- Arising from a do expression + | DoStmtOrigin -- Arising from a do expression | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in -- a do expression | MCompOrigin -- Arising from a monad comprehension @@ -746,7 +746,7 @@ exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches exprCtOrigin (HsIf {}) = IfThenElseOrigin exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e -exprCtOrigin (HsDo {}) = DoOrigin +exprCtOrigin (HsDo {}) = DoStmtOrigin exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {}) = RecordUpdOrigin exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin @@ -769,7 +769,7 @@ exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) hsThingCtOrigin :: HsThingRn -> CtOrigin hsThingCtOrigin (OrigExpr e) = exprCtOrigin e -hsThingCtOrigin (OrigStmt{}) = DoOrigin +hsThingCtOrigin (OrigStmt{}) = DoStmtOrigin hsThingCtOrigin (OrigPat p) = DoPatOrigin p srcCodeCtxtCtOrigin :: HsExpr GhcRn -> SrcCodeCtxt -> CtOrigin @@ -940,7 +940,7 @@ pprCtO (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint" pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" pprCtO DefaultOrigin = text "a 'default' declaration" -pprCtO DoOrigin = text "a do statement" +pprCtO DoStmtOrigin = text "a do statement" pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = text "a proc expression" pprCtO ArrowCmdOrigin = text "an arrow command" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b61531f23e4885ff8065480f7672a029... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b61531f23e4885ff8065480f7672a029... You're receiving this email because of your account on gitlab.haskell.org.