Apoorv Ingle pushed to branch wip/ani/tc-expand at Glasgow Haskell Compiler / GHC Commits: 25625e1e by Apoorv Ingle at 2026-03-18T18:17:17-05:00 making HsExpansion a new datatype - - - - - 17 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/Utils.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/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/Type.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -660,10 +660,14 @@ type instance XXExpr GhcTc = XXExprGhcTc * * ********************************************************************* -} +-- See Note [Rebindable syntax and XXExprGhcRn] +-- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` +data HsExpansion p = HSE { hs_ctxt :: HsCtxt -- The original source thing context to be used for error messages + , expanded_expr :: LHsExpr p } -- The compiler generated, expanded expression + -- This is located because of do statements (TODO ANI : Add Note) + data XXExprGhcRn - = ExpandedThingRn { xrn_orig :: HsCtxt -- The original source thing context to be used for error messages - , xrn_expanded :: LHsExpr GhcRn } -- The compiler generated, expanded thing - -- This is located because of do statements (TODO ANI : Add Note) + = ExpandedThingRn (HsExpansion GhcRn) -- ^ Renamed/Pre Typecheck expanded expression | HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector -- See Note [Non-overloaded record field selectors] and @@ -673,11 +677,7 @@ data XXExprGhcTc = WrapExpr -- Type and evidence application and abstractions HsWrapper (HsExpr GhcTc) - | ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn] - -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` - { xtc_orig :: HsCtxt -- The original user written thing - , xtc_expanded :: LHsExpr GhcTc } -- The expanded typechecked expression - -- This is located because of do statements (TODO ANI: Add NOTE) + | ExpandedThingTc (HsExpansion GhcTc) -- ^ Typechecked expanded expression | ConLikeTc -- ^ A 'ConLike', either a data constructor or pattern synonym @@ -1019,9 +1019,15 @@ ppr_expr (XExpr x) = case ghcPass @p of GhcRn -> ppr x GhcTc -> ppr x -instance Outputable XXExprGhcRn where - ppr (HsRecSelRn f) = pprPrefixOcc f - ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [pprCtxt o, text ";;" , ppr e]) (pprCtxt o) + +ppr_hse :: forall p. (IsPass p) => HsExpansion (GhcPass p) -> SDoc +ppr_hse hse + = case ghcPass @p of + GhcPs -> empty + GhcRn -> case hse of + HSE o e -> ifPprDebug (braces $ vcat [pprCtxt o, text ";;" , ppr e]) (pprCtxt o) + GhcTc -> case hse of + HSE o e -> ifPprDebug (braces $ vcat [pprCtxt o, text ";;" , ppr e]) (pprCtxt o) where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens x)) x pprCtxt :: HsCtxt -> SDoc @@ -1031,26 +1037,17 @@ instance Outputable XXExprGhcRn where pprCtxt (FunAppCtxt (FunAppCtxtExpr _ e) _) = ppr_builder "<FunAppCtxt>:" (ppr e) pprCtxt _ = ppr_builder "<MiscHsCtxt>:" empty +instance Outputable XXExprGhcRn where + ppr (HsRecSelRn f) = pprPrefixOcc f + ppr (ExpandedThingRn hse) = ppr_hse hse + + instance Outputable XXExprGhcTc where ppr (WrapExpr co_fn e) = pprHsWrapper co_fn (\_parens -> pprExpr e) - ppr (ExpandedThingTc o e) - = ifPprDebug (braces $ vcat [pprCtxt o, ppr e]) (pprCtxt o) - - where - ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens x)) x - pprCtxt :: HsCtxt -> SDoc - pprCtxt (ExprCtxt e) = ppr_builder "<OrigExpr>:" (ppr e) - pprCtxt (StmtErrCtxt _ stmt) = ppr_builder "<OrigStmt>:" (ppr stmt) - pprCtxt (StmtErrCtxtPat pat) = ppr_builder "<OrigPat>:" (ppr pat) - pprCtxt (FunAppCtxt (FunAppCtxtExpr _ e) _) = ppr_builder "<FunAppCtxt>:" (ppr e) - pprCtxt _ = ppr_builder "<MiscHsCtxt>:" empty - - -- e is the expanded expression, we print the original - -- expression (HsExpr GhcRn), not the - -- expanded typechecked one (HsExpr GhcTc), - -- unless we are in ppr's debug mode printed both + ppr (ExpandedThingTc hse) + = ppr_hse hse ppr (ConLikeTc con) = pprPrefixOcc con -- Used in error messages generated by @@ -1083,12 +1080,12 @@ ppr_infix_expr (XExpr x) = case ghcPass @p of ppr_infix_expr _ = Nothing ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc -ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing +ppr_infix_expr_rn (ExpandedThingRn (HSE thing _)) = ppr_infix_hs_expansion thing ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f) ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc ppr_infix_expr_tc (WrapExpr _ e) = ppr_infix_expr e -ppr_infix_expr_tc (ExpandedThingTc thing _) = ppr_infix_hs_expansion thing +ppr_infix_expr_tc (ExpandedThingTc (HSE thing _)) = ppr_infix_hs_expansion thing ppr_infix_expr_tc (ConLikeTc con) = Just (pprInfixOcc (conLikeName con)) ppr_infix_expr_tc (HsTick {}) = Nothing ppr_infix_expr_tc (HsBinTick {}) = Nothing @@ -1176,14 +1173,14 @@ hsExprNeedsParens prec = go go_x_tc :: XXExprGhcTc -> Bool go_x_tc (WrapExpr _ e) = hsExprNeedsParens prec e - go_x_tc (ExpandedThingTc thing _) = hsExpandedNeedsParens thing + go_x_tc (ExpandedThingTc (HSE thing _)) = hsExpandedNeedsParens thing go_x_tc (ConLikeTc {}) = False go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e go_x_tc (HsRecSelTc{}) = False go_x_rn :: XXExprGhcRn -> Bool - go_x_rn (ExpandedThingRn thing _ ) = hsExpandedNeedsParens thing + go_x_rn (ExpandedThingRn (HSE thing _)) = hsExpandedNeedsParens thing go_x_rn (HsRecSelRn{}) = False hsExpandedNeedsParens :: HsCtxt -> Bool @@ -1228,14 +1225,14 @@ isAtomicHsExpr (XExpr x) where go_x_tc :: XXExprGhcTc -> Bool go_x_tc (WrapExpr _ e) = isAtomicHsExpr e - go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing + go_x_tc (ExpandedThingTc (HSE thing _)) = isAtomicExpandedThingRn thing go_x_tc (ConLikeTc {}) = True go_x_tc (HsTick {}) = False go_x_tc (HsBinTick {}) = False go_x_tc (HsRecSelTc{}) = True go_x_rn :: XXExprGhcRn -> Bool - go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing + go_x_rn (ExpandedThingRn (HSE thing _)) = isAtomicExpandedThingRn thing go_x_rn (HsRecSelRn{}) = True isAtomicExpandedThingRn :: HsCtxt -> Bool ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -647,6 +647,9 @@ instance Data HsCtxt where deriving instance Data XXExprGhcRn +deriving instance Data (HsExpansion GhcRn) +deriving instance Data (HsExpansion GhcTc) + deriving instance Data a => Data (WithUserRdr a) -- ------------------------------- ===================================== compiler/GHC/Hs/Syn/Type.hs ===================================== @@ -153,7 +153,7 @@ hsExprType (HsQual x _ _) = dataConCantHappen x hsExprType (HsForAll x _ _) = dataConCantHappen x hsExprType (HsFunArr x _ _ _) = dataConCantHappen x hsExprType (XExpr (WrapExpr wrap e)) = hsWrapperType wrap $ hsExprType e -hsExprType (XExpr (ExpandedThingTc _ e)) = lhsExprType e +hsExprType (XExpr (ExpandedThingTc (HSE _ e))) = lhsExprType e hsExprType (XExpr (ConLikeTc con)) = conLikeType con hsExprType (XExpr (HsTick _ e)) = lhsExprType e hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -307,7 +307,7 @@ dsExpr e@(XExpr ext_expr_tc) WrapExpr {} -> dsApp e ConLikeTc {} -> dsApp e - ExpandedThingTc _ e -> dsLExpr e + ExpandedThingTc (HSE _ e) -> dsLExpr e -- Hpc Support HsTick tickish e -> do ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -1166,7 +1166,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- we have to compare the wrappers exp (XExpr (WrapExpr h e)) (XExpr (WrapExpr h' e')) = wrap h h' && exp e e' - exp (XExpr (ExpandedThingTc _ x)) (XExpr (ExpandedThingTc _ x')) + exp (XExpr (ExpandedThingTc (HSE _ x))) (XExpr (ExpandedThingTc (HSE _ x'))) = lexp x x' exp (HsVar _ i) (HsVar _ i') = i == i' exp (HsIPVar _ i) (HsIPVar _ i') = ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1735,7 +1735,7 @@ repE (HsFunArr _ mult arg res) = do arg' <- repLE arg res' <- repLE res repApps fun [arg', res'] -repE e@(XExpr (ExpandedThingRn o x)) +repE e@(XExpr (ExpandedThingRn (HSE o x))) | ExprCtxt e <- o = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax ; if rebindable_on -- See Note [Quotation and rebindable syntax] ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -415,7 +415,7 @@ addTickLHsExpr e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | isGoodBreakExpr e0 -> tick_it - TickForCoverage | XExpr (ExpandedThingTc StmtErrCtxt{} _) <- e0 -- expansion ticks are handled separately + TickForCoverage | XExpr (ExpandedThingTc (HSE StmtErrCtxt{} _)) <- e0 -- expansion ticks are handled separately -> dont_tick_it | otherwise -> tick_it TickCallSites | isCallSite e0 -> tick_it @@ -484,14 +484,14 @@ addTickLHsExprNever (L pos e0) = do -- General heuristic: expressions which are calls (do not denote -- values) are good break points. isGoodBreakExpr :: HsExpr GhcTc -> Bool -isGoodBreakExpr (XExpr (ExpandedThingTc (StmtErrCtxt{}) _)) = False +isGoodBreakExpr (XExpr (ExpandedThingTc (HSE StmtErrCtxt{} _))) = False isGoodBreakExpr e = isCallSite e isCallSite :: HsExpr GhcTc -> Bool isCallSite HsApp{} = True isCallSite HsAppType{} = True isCallSite HsCase{} = True -isCallSite (XExpr (ExpandedThingTc _ e)) +isCallSite (XExpr (ExpandedThingTc (HSE _ e))) = isCallSite (unLoc e) -- NB: OpApp, SectionL, SectionR are all expanded out @@ -637,7 +637,7 @@ addTickHsExpr (HsProc x pat cmdtop) = addTickHsExpr (XExpr (WrapExpr w e)) = liftM (XExpr . WrapExpr w) $ (addTickHsExpr e) -- Explicitly no tick on inside -addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e +addTickHsExpr (XExpr (ExpandedThingTc hse)) = addTickHsExpanded hse addTickHsExpr e@(XExpr (ConLikeTc {})) = return e -- We used to do a freeVar on a pat-syn builder, but actually @@ -660,8 +660,8 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts)) ListComp -> Just $ BinBox QualBinBox _ -> Nothing -addTickHsExpanded :: HsCtxt -> LHsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of +addTickHsExpanded :: HsExpansion GhcTc -> TM (HsExpr GhcTc) +addTickHsExpanded (HSE o e) = liftM (XExpr . ExpandedThingTc . HSE o) $ case o of -- We always want statements to get a tick, so we can step over each one. -- To avoid duplicates we blacklist SrcSpans we already inserted here. StmtErrCtxt _ (L pos _) -> do_tick_black pos ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -755,7 +755,7 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where RecordCon con_expr _ _ -> computeType con_expr ExprWithTySig _ e _ -> computeLType e HsPragE _ _ e -> computeLType e - XExpr (ExpandedThingTc thing e) + XExpr (ExpandedThingTc (HSE thing e)) | ExprCtxt (HsGetField{}) <- thing -- for record-dot-syntax -> Just (lhsExprType e) | otherwise -> computeLType e @@ -1352,7 +1352,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where WrapExpr w a -> [ toHie $ L mspan a , toHie (L mspan w) ] - ExpandedThingTc _ e + ExpandedThingTc (HSE _ e) -> [ toHie e ] ConLikeTc con -> [ toHie $ C Use $ L mspan $ conLikeName con ] ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -847,8 +847,9 @@ mkExpandedStmt oStmt flav eExpr = mkExpandedRn (StmtErrCtxt (HsDoStmt flav) oStm mkExpandedRn :: HsCtxt -- ^ source, user written do statement/expression -> LHsExpr GhcRn -- ^ expanded typechecked expression - -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedRn orig expr = XExpr (ExpandedThingRn orig expr) + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedRn o e = XExpr (ExpandedThingRn (HSE o e)) + -- | Build a 'XXExprGhcRn' out of an extension constructor, -- and the two components of the expansion: original and @@ -862,5 +863,5 @@ mkExpandedExprTc oExpr eExpr = mkExpandedTc (ExprCtxt oExpr) (wrapGenSpan eExpr) mkExpandedTc :: HsCtxt -- ^ source, user written do statement/expression -> LHsExpr GhcTc -- ^ expanded typechecked expression - -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedTc o e = XExpr (ExpandedThingTc o e) + -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcTc' +mkExpandedTc o e = XExpr (ExpandedThingTc (HSE o e)) ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -1246,7 +1246,7 @@ expr_to_type earg = | otherwise = not_in_scope where occ = occName rdr not_in_scope = failWith $ TcRnNotInScope NotInScope rdr - go (L l (XExpr (ExpandedThingRn (ExprCtxt orig) _))) = + go (L l (XExpr (ExpandedThingRn (HSE (ExprCtxt orig) _)))) = -- Use the original, user-written expression (before expansion). -- Example. Say we have vfun :: forall a -> blah -- and the call vfun (Maybe [1,2,3]) @@ -1937,7 +1937,7 @@ quickLookArg1 :: Int -> SrcSpan -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn -> Scaled TcRhoType -- Deeply skolemised -> TcM (HsExprArg 'TcpInst) -- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper -quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Scaled _ orig_arg_rho) +quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) = addArgCtxt pos (fun, fun_lspan) larg $ -- Context needed for constraints -- generated by calls in arg do { ((rn_fun_arg, fun_lspan_arg), rn_args) <- splitHsApps arg @@ -1968,7 +1968,7 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Sca <- captureConstraints $ tcInstFun do_ql True ds_flag_arg (arg_orig, rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args -- We must capture type-class and equality constraints here, but - -- not equality constraints. See (QLA6) in Note [Quick Look at + -- not usage information. See (QLA6) in Note [Quick Look at -- value arguments] ; traceTc "quickLookArg 2" $ ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -45,8 +45,8 @@ import Data.List ((\\)) -- so that they can be typechecked. -- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary -- and Note [Handling overloaded and rebindable constructs] for high level commentary -expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn) -expandDoStmts doFlav stmts = expand_do_stmts doFlav stmts +expandDoStmts :: HsDoFlavour -> XRec GhcRn [ExprLStmt GhcRn] -> TcM (HsExpansion GhcRn) +expandDoStmts doFlav lstmts@(L _ stmts) = HSE (ExprCtxt (HsDo noExtField doFlav lstmts)) <$> expand_do_stmts doFlav stmts -- | The main work horse for expanding do block statements into applications of binds and thens -- See Note [Expanding HsDo with XXExprGhcRn] @@ -234,7 +234,7 @@ See Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr To disabmiguate desugaring (`HsExpr GhcTc -> Core.Expr`) we use the phrase expansion (`HsExpr GhcRn -> HsExpr GhcRn`) -This expansion is done right before typechecking and after renaming +This expansion is done after renaming and before typechecking See Part 2. of Note [Doing XXExprGhcRn in the Renamer vs Typechecker] in `GHC.Rename.Expr` Historical note START @@ -423,10 +423,10 @@ It stores the original statement (with location) and the expanded expression ‹ExpandedThingRn do { e1; e2; e3 }› -- Original Do Expression -- Expanded Do Expression (‹ExpandedThingRn e1› -- Original Statement - ({(>>) ‹ExpandedThingRn e1› e1} -- Expanded Expression + ({(>>) e1} -- Expanded Expression (‹ExpandedThingRn e2› - ({(>>) ‹ExpandedThingRn e2› e2} - (‹ExpandedThingRn e3› {e3}))))) + ({(>>) e2} + (‹ExpandedThingRn e3› {e3}))))) * Whenever the typechecker steps through an `ExpandedThingRn`, we push the original statement in the error context, set the error location to the @@ -481,6 +481,4 @@ It stores the original statement (with location) and the expanded expression mkExpandedPatRn :: LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn -mkExpandedPatRn pat e = XExpr $ ExpandedThingRn - { xrn_orig = StmtErrCtxtPat pat - , xrn_expanded = wrapGenSpan e} +mkExpandedPatRn pat e = mkExpandedRn (StmtErrCtxtPat pat) (wrapGenSpan e) ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -316,7 +316,8 @@ tcExpr e@(OpApp {}) res_ty = tcApp e res_ty tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty -tcExpr (XExpr e') res_ty = tcXExpr e' res_ty +tcExpr (XExpr (ExpandedThingRn hse)) res_ty = tcHsExpansion hse res_ty +tcExpr e@(XExpr{}) res_ty = tcApp e res_ty -- Typecheck an occurrence of an unbound Id -- @@ -557,7 +558,7 @@ tcExpr (HsMultiIf _ alts) res_ty ; res_ty <- readExpType res_ty ; return (HsMultiIf res_ty alts') } -tcExpr expr@(HsDo _ do_or_lc stmts) res_ty +tcExpr (HsDo _ do_or_lc stmts) res_ty | DoExpr{} <- do_or_lc -- ApplicativeDo are typechecked using tcDoStmts = do isApplicativeDo <- xoptM LangExt.ApplicativeDo @@ -565,12 +566,13 @@ tcExpr expr@(HsDo _ do_or_lc stmts) res_ty then tcDoStmts do_or_lc stmts res_ty -- Expand expression on the fly otherwise -- See Note [Typechecking by expansion: overview] - else do { expr' <- tcExpandExpr expr - ; tcExpr expr' res_ty } + else do { hse <- expandDoStmts do_or_lc stmts + ; tcHsExpansion hse res_ty } | MDoExpr{} <- do_or_lc - = do expr' <- tcExpandExpr expr - tcExpr expr' res_ty + = do hse <- expandDoStmts do_or_lc stmts + tcHsExpansion hse res_ty | otherwise + -- ListComp, MonadComp are handled by tcDoStmts = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc x pat cmd) res_ty @@ -686,7 +688,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr ; (ds_expr, ds_res_ty, err_msg) <- expandRecordUpd record_expr possible_parents rbnds res_ty - ; setInGeneratedCode $ addErrCtxt err_msg $ + ; addErrCtxt err_msg $ 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. @@ -815,7 +817,7 @@ The rest of this Note explains how that is done. hence `RealSrcSpan`. The `tcl_err_ctxt` is a stack of contexts, each saying something - like "In the expression: x+y" or "In the record update: r { x=2 }" + like "In the expression: x+y" or "In second argument of `$` namely 'r { x=2 }'" The `tcl_in_gen_code` is a boolean that keeps track of whether the current expression being typechecked is compiler generated @@ -847,17 +849,13 @@ The rest of this Note explains how that is done. -} -tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcXExpr (ExpandedThingRn o e) res_ty +tcHsExpansion :: HsExpansion GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcHsExpansion (HSE o e) res_ty = mkExpandedTc o <$> -- necessary for hpc ticks -- Need to call tcExpr and not tcApp -- as e can be let statement which tcApp cannot gracefully handle tcMonoLExpr e res_ty --- For record selection, same as HsVar case -tcXExpr xe res_ty = tcApp (XExpr xe) res_ty - - {- ************************************************************************ * * @@ -1859,14 +1857,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 ===================================== @@ -462,7 +462,7 @@ tcInferAppHead_maybe fun = case fun of ExprWithTySig _ e hs_ty -> Just <$> with_get_ds (tcExprWithSig e hs_ty) HsOverLit _ lit -> Just <$> with_get_ds (tcInferOverLit lit) XExpr (HsRecSelRn f) -> Just <$> with_get_ds (tcInferRecSelId f) - XExpr (ExpandedThingRn o (L loc e)) -> setSrcSpan (locA loc) $ Just <$> ( + XExpr (ExpandedThingRn (HSE o (L loc e))) -> setSrcSpan (locA loc) $ Just <$> ( -- We do not want to instantiate the type of the head as there may be -- visible type applications in the argument. -- c.f. T19167 ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -625,7 +625,7 @@ 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 o _)) = errCtxtCtOrigin o +exprCtOrigin (XExpr (ExpandedThingRn (HSE o _))) = errCtxtCtOrigin o exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) srcCodeOriginCtOrigin :: HsCtxt -> CtOrigin ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1089,7 +1089,7 @@ setSrcSpan :: SrcSpan -> TcRn a -> TcRn a setSrcSpan (RealSrcSpan loc _) thing_inside = updLclCtxt (\ctxt -> ctxt {tcl_loc = loc, tcl_in_gen_code = False}) thing_inside setSrcSpan (GeneratedSrcSpan{}) thing_inside - = setInGeneratedCode $ thing_inside + = updLclCtxt (\ctxt -> ctxt {tcl_in_gen_code = True}) thing_inside setSrcSpan _ thing_inside = thing_inside @@ -1355,8 +1355,8 @@ addLExprCtxt lspan e thing_inside -- error context. c.f. RecordDotSyntaxFail9 -- Add the original HsCtxt if we are typechecking an expanded expression ExprWithTySig _ (L _ e') _ - | XExpr (ExpandedThingRn o _) <- e' -> addErrCtxt o thing_inside - XExpr (ExpandedThingRn o _) -> addErrCtxt o thing_inside + | XExpr (ExpandedThingRn (HSE o _)) <- e' -> addErrCtxt o thing_inside + XExpr (ExpandedThingRn (HSE o _)) -> addErrCtxt o thing_inside _ -> addErrCtxt (ExprCtxt e) thing_inside } ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -2047,7 +2047,7 @@ getDeepSubsumptionFlag_DataConHead app_head = go app_head | XExpr (ConLikeTc (RealDataCon {})) <- app_head = Deep TopSub - | XExpr (ExpandedThingTc _ (L _ f)) <- app_head + | XExpr (ExpandedThingTc (HSE _ (L _ f))) <- app_head = go f | XExpr (WrapExpr _ f) <- app_head = go f ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -1095,9 +1095,9 @@ zonkExpr (XExpr (WrapExpr co_fn expr)) do new_expr <- zonkExpr expr return (XExpr (WrapExpr new_co_fn new_expr)) -zonkExpr (XExpr (ExpandedThingTc thing e)) +zonkExpr (XExpr (ExpandedThingTc (HSE thing e))) = do e' <- zonkLExpr e - return $ XExpr (ExpandedThingTc thing e') + return $ XExpr (ExpandedThingTc (HSE thing e')) zonkExpr e@(XExpr (ConLikeTc {})) = return e View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25625e1e23f81193423092ad1f6fbd4c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25625e1e23f81193423092ad1f6fbd4c... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Apoorv Ingle (＠ani)