Apoorv Ingle pushed to branch wip/ani/tc-expand at Glasgow Haskell Compiler / GHC Commits: 3b036900 by Apoorv Ingle at 2026-03-13T18:34:40-05:00 wibbles - - - - - 3 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Tc.Gen.App , tcExprSigma , tcExprPrag ) where -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyLExprNC ) import GHC.Hs @@ -570,7 +570,7 @@ tcValArg do_ql _ _ (EWrap (EHsWrap w)) = do { whenQL do_ql $ qlMonoHsWrapper w tcValArg _ _ _ (EWrap ew) = return (EWrap ew) tcValArg do_ql pos (fun, fun_lspan) (EValArg { ea_loc_span = lspan - , ea_arg = larg@(L arg_loc arg) + , ea_arg = larg@(L arg_loc _) , ea_arg_ty = sc_arg_ty }) = addArgCtxt pos (fun, fun_lspan) larg $ do { -- Crucial step: expose QL results before checking exp_arg_ty @@ -596,11 +596,11 @@ tcValArg do_ql pos (fun, fun_lspan) (EValArg { ea_loc_span = lspan -- Now check the argument ; arg' <- tcScalingUsage mult $ - tcPolyExpr arg (mkCheckExpType exp_arg_ty) + tcPolyLExprNC larg (mkCheckExpType exp_arg_ty) ; traceTc "tcValArg" $ vcat [ ppr arg' , text "}" ] ; return (EValArg { ea_loc_span = lspan - , ea_arg = L arg_loc arg' + , ea_arg = arg' , ea_arg_ty = noExtField }) } tcValArg _ pos (fun, fun_lspan) (EValArgQL { ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -123,30 +123,11 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType tcPolyLExpr (L loc expr) res_ty = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] - do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty - ; e <- - mb_add_xexpr_wrap (ExprCtxt expr) did_expand $ mb_add_ctxt ctxt (locA loc') expanded_expr $ - case mb_ret_ty of - Nothing -> tcPolyExpr expanded_expr res_ty - Just ds_res_ty -> do expr' <- tcPolyExpr expanded_expr (Check ds_res_ty) - tcWrapResult expr expr' ds_res_ty res_ty - ; return (L loc' e) - } - where - mb_add_ctxt :: Maybe HsCtxt -> SrcSpan -> HsExpr GhcRn -> TcM a -> TcM a - mb_add_ctxt Nothing _ _ thing_inside - = thing_inside - mb_add_ctxt (Just ctxt) loc expanded_expr thing_inside - = addExpansionErrCtxt ctxt $ - addLExprCtxt loc expanded_expr $ - thing_inside - - mb_add_xexpr_wrap :: HsCtxt -> Bool -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc) - mb_add_xexpr_wrap hs_ctxt True thing_inside = mkExpandedTc hs_ctxt <$> setInGeneratedCode thing_inside - mb_add_xexpr_wrap _ False thing_inside = thing_inside + tcPolyLExprNC (L loc expr) res_ty tcPolyLExprNC (L loc expr) res_ty - = do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty + = setSrcSpanA loc $ + do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty ; e <- mb_add_xexpr_wrap (ExprCtxt expr) did_expand $ mb_add_ctxt ctxt (locA loc') expanded_expr $ case mb_ret_ty of @@ -313,30 +294,11 @@ tcMonoLExpr, tcMonoLExprNC tcMonoLExpr (L loc expr) res_ty = addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] - do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty - ; e <- - mb_add_xexpr_wrap (ExprCtxt expr) did_expand $ mb_add_ctxt ctxt (locA loc') expanded_expr $ - case mb_ret_ty of - Nothing -> tcExpr expanded_expr res_ty - Just ds_res_ty -> do expr' <- tcExpr expanded_expr (Check ds_res_ty) - tcWrapResultMono expr expr' ds_res_ty res_ty - ; return (L loc' e) - } - where - mb_add_ctxt :: Maybe HsCtxt -> SrcSpan -> HsExpr GhcRn -> TcM a -> TcM a - mb_add_ctxt Nothing _ _ thing_inside - = thing_inside - mb_add_ctxt (Just ctxt) loc expanded_expr thing_inside - = addExpansionErrCtxt ctxt $ - addLExprCtxt loc expanded_expr $ - thing_inside - - mb_add_xexpr_wrap :: HsCtxt -> Bool -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc) - mb_add_xexpr_wrap hs_ctxt True thing_inside = mkExpandedTc hs_ctxt <$> setInGeneratedCode thing_inside - mb_add_xexpr_wrap _ False thing_inside = thing_inside + tcMonoLExprNC (L loc expr) res_ty tcMonoLExprNC (L loc expr) res_ty - = do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty + = setSrcSpanA loc $ + do { (L loc' expanded_expr, mb_ret_ty, ctxt, did_expand) <- tcExpandLExpr loc expr res_ty ; e <- mb_add_xexpr_wrap (ExprCtxt expr) did_expand $ mb_add_ctxt ctxt (locA loc') expanded_expr $ case mb_ret_ty of ===================================== compiler/GHC/Tc/Gen/Expr.hs-boot ===================================== @@ -24,7 +24,7 @@ tcCheckMonoExpr, tcCheckMonoExprNC :: -> TcRhoType -> TcM (LHsExpr GhcTc) -tcPolyLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) +tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc) tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b036900b32dfa9aab96a2da22ac7eeb... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3b036900b32dfa9aab96a2da22ac7eeb... You're receiving this email because of your account on gitlab.haskell.org.