Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 45a1bed0 by Apoorv Ingle at 2026-03-18T00:58:42-05:00 make HsExpandedRn and HsExpandedTc payload LExpr, add tcExpand for expanding Do expressions before typechecking in tcExpr - - - - - 17 changed files: - compiler/GHC/Hs/Expr.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/Gen/Match.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/Type.hs - testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -661,43 +661,23 @@ type instance XXExpr GhcTc = XXExprGhcTc ********************************************************************* -} data XXExprGhcRn - = ExpandedThingRn { xrn_orig :: HsCtxt -- The original source thing context to be used for error messages - , xrn_expanded :: HsExpr GhcRn -- The compiler generated, expanded thing - } + = 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) | HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector -- See Note [Non-overloaded record field selectors] and -- Note [Record selectors in the AST] --- | Build an expression using the extension constructor `XExpr`, --- and the two components of the expansion: original expression and --- expanded expressions. -mkExpandedExpr - :: HsExpr GhcRn -- ^ source expression context - -> HsExpr GhcRn -- ^ expanded expression - -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn { xrn_orig = ExprCtxt oExpr - , xrn_expanded = eExpr }) - --- | Build an expression using the extension constructor `XExpr`, --- and the two components of the expansion: original do stmt and --- expanded expression -mkExpandedStmt - :: ExprLStmt GhcRn -- ^ source statement context - -> HsDoFlavour -- ^ source statements do flavour - -> HsExpr GhcRn -- ^ expanded expression - -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = StmtErrCtxt (HsDoStmt flav) oStmt - , xrn_expanded = eExpr }) - 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 :: HsExpr GhcTc } -- The expanded typechecked expression + { 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) | ConLikeTc -- ^ A 'ConLike', either a data constructor or pattern synonym @@ -722,22 +702,6 @@ data XXExprGhcTc -- See Note [Non-overloaded record field selectors] and -- Note [Record selectors in the AST] - --- | Build a 'XXExprGhcRn' out of an extension constructor, --- and the two components of the expansion: original and --- expanded typechecked expressions. -mkExpandedExprTc - :: HsExpr GhcRn -- ^ source expression - -> HsExpr GhcTc -- ^ expanded typechecked expression - -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedExprTc oExpr eExpr = mkExpandedTc (ExprCtxt oExpr) eExpr - -mkExpandedTc - :: HsCtxt -- ^ source, user written do statement/expression - -> HsExpr GhcTc -- ^ expanded typechecked expression - -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' -mkExpandedTc o e = XExpr (ExpandedThingTc o e) - {- ********************************************************************* * * Pretty-printing expressions ===================================== 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)) = hsExprType e +hsExprType (XExpr (ExpandedThingTc _ 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 ===================================== @@ -41,7 +41,6 @@ import GHC.Hs -- needs to see source types import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence -import GHC.Tc.Types.ErrCtxt import GHC.Tc.Utils.Monad import GHC.Tc.Instance.Class (lookupHasFieldLabel) @@ -308,10 +307,7 @@ dsExpr e@(XExpr ext_expr_tc) WrapExpr {} -> dsApp e ConLikeTc {} -> dsApp e - ExpandedThingTc o e - | StmtErrCtxt _ (L loc _) <- o -- c.f. T14546d. We have lost the location of the first statement in the GhcRn -> GhcTc - -> putSrcSpanDsA loc $ dsExpr e - | otherwise -> dsExpr e + ExpandedThingTc _ e -> dsLExpr e -- Hpc Support HsTick tickish e -> do ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -1167,7 +1167,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp (XExpr (WrapExpr h e)) (XExpr (WrapExpr h' e')) = wrap h h' && exp e e' exp (XExpr (ExpandedThingTc _ x)) (XExpr (ExpandedThingTc _ x')) - = exp x x' + = lexp x x' exp (HsVar _ i) (HsVar _ i') = i == i' exp (HsIPVar _ i) (HsIPVar _ i') = -- the instance for IPName derives using the id, so follow the HsVar case ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1739,7 +1739,7 @@ repE e@(XExpr (ExpandedThingRn o x)) | ExprCtxt e <- o = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax ; if rebindable_on -- See Note [Quotation and rebindable syntax] - then repE x + then repLE x else repE e } | otherwise = notHandled (ThExpressionForm e) ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -492,7 +492,7 @@ isCallSite HsApp{} = True isCallSite HsAppType{} = True isCallSite HsCase{} = True isCallSite (XExpr (ExpandedThingTc _ e)) - = isCallSite e + = isCallSite (unLoc e) -- NB: OpApp, SectionL, SectionR are all expanded out isCallSite _ = False @@ -660,14 +660,14 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts)) ListComp -> Just $ BinBox QualBinBox _ -> Nothing -addTickHsExpanded :: HsCtxt -> HsExpr GhcTc -> TM (HsExpr GhcTc) +addTickHsExpanded :: HsCtxt -> LHsExpr GhcTc -> TM (HsExpr GhcTc) addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc 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 _ -> skip where - skip = addTickHsExpr e + skip = addTickLHsExpr e do_tick_black pos = do d <- getDensity case d of @@ -675,9 +675,9 @@ addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of TickForBreakPoints -> tick_it_black pos _ -> skip tick_it_black pos = - unLoc <$> allocTickBox (ExpBox False) False False (locA pos) + allocTickBox (ExpBox False) False False (locA pos) (withBlackListed (locA pos) $ - addTickHsExpr e) + addTickHsExpr (unLoc e)) addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -757,8 +757,8 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where HsPragE _ _ e -> computeLType e XExpr (ExpandedThingTc thing e) | ExprCtxt (HsGetField{}) <- thing -- for record-dot-syntax - -> Just (hsExprType e) - | otherwise -> computeType e + -> Just (lhsExprType e) + | otherwise -> computeLType e XExpr (HsTick _ e) -> computeLType e XExpr (HsBinTick _ _ e) -> computeLType e e -> Just (hsExprType e) @@ -1353,7 +1353,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where -> [ toHie $ L mspan a , toHie (L mspan w) ] ExpandedThingTc _ e - -> [ toHie (L mspan e) ] + -> [ toHie e ] ConLikeTc con -> [ toHie $ C Use $ L mspan $ conLikeName con ] HsTick _ expr ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -24,6 +24,8 @@ module GHC.Rename.Utils ( genSimpleFunBind, genFunBind, genHsLamDoExp, genHsCaseAltDoExp, genSimpleMatch, genHsLet, + mkExpandedRn, mkExpandedExpr, mkExpandedStmt, mkExpandedLExpr, mkExpandedTc, mkExpandedExprTc, + mkRnSyntaxExpr, newLocalBndrRn, newLocalBndrsRn, @@ -45,7 +47,6 @@ import GHC.Core.Type import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Errors.Types --- import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Types.Name import GHC.Types.Name.Set @@ -816,3 +817,50 @@ genSimpleMatch ctxt pats rhs = wrapGenSpan $ Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = noLocA pats , m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn } + + +-- | Build an expression using the extension constructor `XExpr`, +-- and the two components of the expansion: original expression and +-- expanded expressions. +mkExpandedExpr + :: HsExpr GhcRn -- ^ source expression context + -> HsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedExpr oExpr eExpr = mkExpandedRn (ExprCtxt oExpr) (wrapGenSpan eExpr) + +mkExpandedLExpr + :: HsExpr GhcRn -- ^ source expression context + -> LHsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedLExpr oExpr eExpr = mkExpandedRn (ExprCtxt oExpr) eExpr + +-- | Build an expression using the extension constructor `XExpr`, +-- and the two components of the expansion: original do stmt and +-- expanded expression +mkExpandedStmt + :: ExprLStmt GhcRn -- ^ source statement context + -> HsDoFlavour -- ^ source statements do flavour + -> HsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedStmt oStmt flav eExpr = mkExpandedRn (StmtErrCtxt (HsDoStmt flav) oStmt) (wrapGenSpan eExpr) + +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) + +-- | Build a 'XXExprGhcRn' out of an extension constructor, +-- and the two components of the expansion: original and +-- expanded typechecked expressions. +mkExpandedExprTc + :: HsExpr GhcRn -- ^ source expression + -> HsExpr GhcTc -- ^ expanded typechecked expression + -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' +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) ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -957,8 +957,8 @@ addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside , ppr arg , ppr arg_no]) ; setSrcSpanA arg_loc $ - addNthFunArgErrCtxt app_head arg arg_no $ - thing_inside + addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $ + thing_inside } | otherwise = do { traceTc "addArgCtxt" (vcat [text "generated Head" @@ -969,16 +969,6 @@ addArgCtxt arg_no (app_head, app_head_lspan) (L arg_loc arg) thing_inside ; addLExprCtxt (locA arg_loc) arg $ thing_inside } - where - addNthFunArgErrCtxt :: HsExpr GhcRn -> HsExpr GhcRn -> Int -> TcM a -> TcM a - addNthFunArgErrCtxt app_head arg arg_no thing_inside - | XExpr (ExpandedThingRn _ _) <- arg - = addExpansionErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $ - thing_inside - | otherwise - = addErrCtxt (FunAppCtxt (FunAppCtxtExpr app_head arg) arg_no) $ - thing_inside - {- ********************************************************************* @@ -1950,13 +1940,10 @@ quickLookArg1 :: Int -> SrcSpan -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc 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 - ; let fun_lspan_arg | null rn_args = locA arg_loc -- arg is an id (or an XExpr) so use the arg_loc in tcInstFun - | otherwise = fun_lspan_arg' + 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) <- maybe_update_err_ctxt fun_lspan_arg rn_fun_arg $ - (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 @@ -2025,20 +2012,6 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Sca , eaql_res_rho = app_res_rho }) }}} -maybe_update_err_ctxt :: SrcSpan -> HsExpr GhcRn -> TcM a -> TcM a -maybe_update_err_ctxt fun_lspan_arg rn_fun_arg thing_inside - | not (isGeneratedSrcSpan fun_lspan_arg) - , XExpr (ExpandedThingRn{}) <- rn_fun_arg - = do igc <- inGeneratedCode - if igc - then thing_inside - else addLExprCtxt fun_lspan_arg rn_fun_arg $ - thing_inside - | otherwise - = thing_inside - - - mk_origin :: SrcSpan -- SrcSpan of the argument -> HsExpr GhcRn -- The head of the expression application chain -> TcM CtOrigin ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -14,8 +14,7 @@ module GHC.Tc.Gen.Do (expandDoStmts) where import GHC.Prelude -import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet, - genHsLamDoExp, genHsCaseAltDoExp, genWildPat ) +import GHC.Rename.Utils import GHC.Rename.Env ( irrefutableConLikeRn ) import GHC.Tc.Utils.Monad @@ -114,7 +113,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) | otherwise = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt) -expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L e_lspan e) (SyntaxExprRn then_op) _)) : lstmts) = +expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _ e) (SyntaxExprRn then_op) _)) : lstmts) = -- See Note [BodyStmt] in Language.Haskell.Syntax.Expr -- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below -- stmts ~~> stmts' @@ -122,7 +121,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L e_lspan e) (SyntaxExprRn t -- e ; stmts ~~> (>>) e stmts' do expand_stmts_expr <- expand_do_stmts doFlavour lstmts let expansion = genHsExpApps then_op -- (>>) - [ L e_lspan (mkExpandedStmt stmt doFlavour e) + [ wrapGenSpan e , expand_stmts_expr ] return $ L loc (mkExpandedStmt stmt doFlavour expansion) @@ -484,4 +483,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 = e} + , xrn_expanded = wrapGenSpan e} ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -36,6 +36,7 @@ import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls ) import GHC.Tc.Gen.App import GHC.Tc.Gen.Head +import GHC.Tc.Gen.Do import GHC.Tc.Gen.Bind ( tcLocalBinds ) import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Arrow @@ -92,6 +93,8 @@ import GHC.Data.Maybe import Control.Monad import qualified Data.List.NonEmpty as NE +import qualified GHC.LanguageExtensions as LangExt + {- ************************************************************************ * * @@ -267,13 +270,6 @@ tcCheckMonoExpr, tcCheckMonoExprNC tcCheckMonoExpr expr res_ty = tcMonoLExpr expr (mkCheckExpType res_ty) tcCheckMonoExprNC expr res_ty = tcMonoLExprNC expr (mkCheckExpType res_ty) - --- Expand the HsExpr if it is typechecked after expansions --- See Note [Handling overloaded and rebindable constructs] --- See Note [Typechecking by expansion: overview] -expand_expr :: HsExpr GhcRn -> TcM (HsExpr GhcRn) -expand_expr x = return x - --------------- tcMonoLExpr, tcMonoLExprNC :: LHsExpr GhcRn -- Expression to type check @@ -282,8 +278,7 @@ tcMonoLExpr, tcMonoLExprNC -> TcM (LHsExpr GhcTc) tcMonoLExpr (L loc expr) res_ty - = do expanded_expr <- expand_expr expr - addLExprCtxt (locA loc) expanded_expr $ -- Note [Error contexts in generated code] + = do addLExprCtxt (locA loc) expr $ -- Note [Error contexts in generated code] do { expr' <- tcExpr expr res_ty ; return (L loc expr') } @@ -562,7 +557,20 @@ tcExpr (HsMultiIf _ alts) res_ty ; res_ty <- readExpType res_ty ; return (HsMultiIf res_ty alts') } -tcExpr (HsDo _ do_or_lc stmts) res_ty +tcExpr expr@(HsDo _ do_or_lc stmts) res_ty + | DoExpr{} <- do_or_lc + -- ApplicativeDo are typechecked using tcDoStmts + = do isApplicativeDo <- xoptM LangExt.ApplicativeDo + if isApplicativeDo + 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 } + | MDoExpr{} <- do_or_lc + = do expr' <- tcExpandExpr expr + tcExpr expr' res_ty + | otherwise = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc x pat cmd) res_ty @@ -678,7 +686,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr ; (ds_expr, ds_res_ty, err_msg) <- expandRecordUpd record_expr possible_parents rbnds res_ty - ; addExpansionErrCtxt err_msg $ + ; setInGeneratedCode $ 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. @@ -776,12 +784,12 @@ directly, it's much easier to Example: record updates. The typechecker looks like this: - tcExpr e@(RecordUpd{}) rho = do { ee <- expandExpr e - ; tcExpr ee rho } + tcExpr e@(HsDo{}) rho = do { ee <- expandExpr e + ; tcExpr ee rho } -The `expandExpr` replaces the record update (e { x = rhs }) +The `expandExpr` replaces the HsDo { x <- e1; return x } with something like - case e of { MkT a b _ d -> MkT a b rhs d } + e1 >>= \ x -> x and we then typecheck the latter. See also Note [Handling overloaded and rebindable constructs] @@ -798,8 +806,9 @@ The rest of this Note explains how that is done. , xrn_expanded = ee } )) where `ee` is the expansion of the user written thing `ue` -* The type checker context has 2 key fields that describe the context: +* The type checker context has 3 key fields that describe the context: TcLclCtxt { tcl_loc :: RealSrcSpan + , tcl_in_gen_code :: Bool , tcl_err_ctxt :: [ErrCtxt] , ... } Note `tcl_loc` always points to a real place in the source code, @@ -808,8 +817,12 @@ The rest of this Note explains how that is done. 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 }" + The `tcl_in_gen_code` is a boolean that keeps track of whether + the current expression being typechecked is compiler generated + or user generated. + * Now, when - tcMonoLHsExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) + tcMonoLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) gets a located expression, it does 2 things: * Calls `addLExprCtxt` to perform error context management * Calls `tcExpr` to typecheck the expression. @@ -839,7 +852,7 @@ tcXExpr (ExpandedThingRn 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 - tcExpr e res_ty + tcMonoLExpr e res_ty -- For record selection, same as HsVar case tcXExpr xe res_ty = tcApp (XExpr xe) res_ty @@ -1846,3 +1859,14 @@ 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 ===================================== @@ -29,6 +29,8 @@ import GHC.Prelude import GHC.Hs import GHC.Hs.Syn.Type +import GHC.Rename.Utils (mkExpandedTc, mkExpandedExprTc) + import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Bind( chooseInferredQuantifiers ) import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig ) @@ -460,12 +462,12 @@ 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 e) -> Just <$> ( + XExpr (ExpandedThingRn 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 - (\ (e, ds_flag, ty) -> (mkExpandedTc o e, ds_flag, ty)) <$> - tcExprSigma False (errCtxtCtOrigin o) e + (\ (e, ds_flag, ty) -> (mkExpandedTc o (L loc e), ds_flag, ty)) <$> + tcExprSigma False (errCtxtCtOrigin o) e ) _ -> return Nothing ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -35,7 +35,7 @@ where import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoFRRNC - , tcMonoLExprNC, tcMonoLExpr, tcExpr + , tcMonoLExprNC, tcExpr , tcCheckMonoExpr, tcCheckMonoExprNC , tcCheckPolyExpr, tcPolyLExpr ) @@ -44,7 +44,6 @@ import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Pat -import GHC.Tc.Gen.Do import GHC.Tc.Gen.Head( tcCheckId ) import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -391,32 +390,14 @@ tcDoStmts MonadComp (L l stmts) res_ty ; res_ty <- readExpType res_ty ; return (HsDo res_ty MonadComp (L l stmts')) } -tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt) - -tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty - = do { isApplicativeDo <- xoptM LangExt.ApplicativeDo - ; if isApplicativeDo - then do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty doExpr (L l stmts')) } - else do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly - ; traceTc "tcDoStmts" (ppr expanded_expr) - ; let orig = HsDo noExtField doExpr ss - ; mkExpandedExprTc orig <$> ( - -- We lose the location on the first statement location in GhcTc, unfortunately. - -- It is needed for get the pattern match warnings right cf. T14546d - -- That location is currently recovered from the location stored in OrigStmt - -- in dsExpr of ExpandedThingTc - unLoc <$> tcMonoLExpr expanded_expr res_ty) - } - } -tcDoStmts mDoExpr ss@(L _ stmts) res_ty - = do { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly - ; let orig = HsDo noExtField mDoExpr ss - ; e' <- tcMonoLExpr expanded_expr res_ty - ; return (mkExpandedExprTc orig (unLoc e')) - } +tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty + = do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty + ; res_ty <- readExpType res_ty + ; return (HsDo res_ty doExpr (L l stmts')) } + +-- NB: ghcistmts should fail, MDoExpr is handled by expansions +tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt) tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) tcBody body res_ty ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -88,7 +88,7 @@ module GHC.Tc.Utils.Monad( -- * Context management for the type checker getErrCtxt, setErrCtxt, addErrCtxt, - addLExprCtxt, addExpansionErrCtxt, + addLExprCtxt, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv, -- * Diagnostic message generation (type checker) @@ -1316,11 +1316,16 @@ problem. Note [Error contexts in generated code] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* If the `SrcSpan` is a `RealSrcSpan`, `setSrcSpan` updates the `tcl_loc`, - and makes the `ErrCtxStack` a `UserCodeCtxt` -* it is a no-op otherwise -So, it's better to do a `setSrcSpan` /before/ `addErrCtxt`. +* addLExpr updates updates the ErrCtxt stored in LclEnv with the following logic + - If the `SrcSpan` is a `RealSrcSpan`, `setSrcSpan` updates the `tcl_loc` to the given value + and sets `tcl_in_gen_code` to `False`. Meaning we are not type checking a compiler generated + expression. And thus it can add the expression on to the ErrCtxt Stack + - If the `SrcSpan` is a GeneratedSrcSpan then `tcl_in_gen_code` is set to `True`, meaning + the expression in hand is compiler generated, and hence it is not added on to the stack. + +This ensures that the error messages do not leak compiler generated expressions which can +be confusing to the users. - See Note [Rebindable syntax and XXExprGhcRn] in `GHC.Hs.Expr` for more discussion of this fancy footwork @@ -1329,33 +1334,32 @@ relation with pattern-match checks - See Note [ErrCtxtStack Manipulation] in `GHC.Tc.Types.LclEnv` for info about `ErrCtxtStack` -} +-- See Note [Error contexts in generated code] addLExprCtxt :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a addLExprCtxt lspan e thing_inside - | not (isGeneratedSrcSpan lspan) = setSrcSpan lspan $ add_expr_ctxt e thing_inside - | otherwise -- no op in generated code - = thing_inside where - add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a - add_expr_ctxt e thing_inside - = case e of - -- The HsHole special case addresses situations like - -- f x = _ - -- when we don't want to say "In the expression: _", - -- because it is mentioned in the error message itself - HsHole{} -> thing_inside - - -- There is a special case for expressions with signatures to avoid having too verbose - -- error context. So here we flip the ErrCtxt state to expanded if the expression is expanded. - -- c.f. RecordDotSyntaxFail9 - ExprWithTySig _ (L _ e') _ - | XExpr (ExpandedThingRn o _) <- e' -> addExpansionErrCtxt o thing_inside - - -- Flip error ctxt into expansion mode - XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o thing_inside - - _ -> addErrCtxt (ExprCtxt e) thing_inside - + add_expr_ctxt :: HsExpr GhcRn -> TcRn a -> TcRn a + add_expr_ctxt e thing_inside + = do { igc <- inGeneratedCode + ; if igc -- generated + then thing_inside + else case e of + -- The HsHole special case addresses situations like + -- f x = _ + -- when we don't want to say "In the expression: _", + -- because it is mentioned in the error message itself + HsHole{} -> thing_inside + + -- There is a special case for expressions with signatures to avoid having too verbose + -- 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 + + _ -> addErrCtxt (ExprCtxt e) thing_inside + } getErrCtxt :: TcM [ErrCtxt] getErrCtxt = do { env <- getLclEnv; return (getLclEnvErrCtxt env) } @@ -1369,11 +1373,6 @@ addErrCtxt :: HsCtxt -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt ctxt = pushCtxt ctxt --- See Note [ErrCtxtStack Manipulation] -addExpansionErrCtxt :: HsCtxt -> TcM a -> TcM a -{-# INLINE addExpansionErrCtxt #-} -- Note [Inlining addErrCtxt] -addExpansionErrCtxt ctxt thing_inside = setInGeneratedCode $ pushCtxt ctxt thing_inside - -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr pushCtxt :: ErrCtxt -> TcM a -> TcM a {-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt] ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -105,7 +105,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Basic import GHC.Types.Unique.Set (nonDetEltsUniqSet) -import GHC.Types.SrcLoc (unLoc) +import GHC.Types.SrcLoc (unLoc, GenLocated (..)) import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable @@ -2047,7 +2047,7 @@ getDeepSubsumptionFlag_DataConHead app_head = go app_head | XExpr (ConLikeTc (RealDataCon {})) <- app_head = Deep TopSub - | XExpr (ExpandedThingTc _ f) <- app_head + | XExpr (ExpandedThingTc _ (L _ f)) <- app_head = go f | XExpr (WrapExpr _ f) <- app_head = go f ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -1096,7 +1096,7 @@ zonkExpr (XExpr (WrapExpr co_fn expr)) return (XExpr (WrapExpr new_co_fn new_expr)) zonkExpr (XExpr (ExpandedThingTc thing e)) - = do e' <- zonkExpr e + = do e' <- zonkLExpr e return $ XExpr (ExpandedThingTc thing e') zonkExpr e@(XExpr (ConLikeTc {})) ===================================== testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout ===================================== @@ -9,6 +9,7 @@ e/E.hs:(15,3)-(15,6): GHC.Internal.Types.Int -> GHC.Internal.Base.String e/E.hs:(22,3)-(22,6): E.E -> GHC.Internal.Base.String e/E.hs:(25,3)-(25,10): GHC.Internal.Base.String -> GHC.Internal.Types.IO () e/E.hs:(25,12)-(25,37): GHC.Internal.Base.String +e/E.hs:(25,3)-(25,37): GHC.Internal.Types.IO () e/E.hs:(24,16)-(25,37): GHC.Internal.Types.IO () e/E.hs:(19,9)-(19,9): E.E e/E.hs:(5,7)-(5,8): GHC.Internal.Bignum.Integer.Integer View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45a1bed03c0c0dd7bf5859d6db7bf6f0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45a1bed03c0c0dd7bf5859d6db7bf6f0... You're receiving this email because of your account on gitlab.haskell.org.