Apoorv Ingle pushed to branch wip/ani/tc-expand at Glasgow Haskell Compiler / GHC Commits: c056178d by Apoorv Ingle at 2026-03-19T08:58:12-05:00 make HsExpandedRn and HsExpandedTc payload LExpr, add tcExpand for expanding Do expressions before typechecking in tcExpr - - - - - 48d25b0c by Apoorv Ingle at 2026-03-19T08:58:48-05:00 making HsExpansion a new datatype - - - - - 20 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/Gen/Match.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 - testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -660,44 +660,24 @@ 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 :: HsExpr GhcRn -- The compiler generated, expanded thing - } + = ExpandedThingRn (HsExpansion GhcRn) -- ^ Renamed/Pre Typecheck expanded expression | 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 + | ExpandedThingTc (HsExpansion GhcTc) -- ^ Typechecked expanded expression | 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 @@ -1055,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 @@ -1067,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 @@ -1119,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 @@ -1212,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 @@ -1264,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)) = hsExprType 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 ===================================== @@ -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 (HSE _ e) -> dsLExpr e -- Hpc Support HsTick tickish e -> do ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -1166,8 +1166,8 @@ 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 x 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') = -- 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 ===================================== @@ -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,15 +484,15 @@ 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 e +isCallSite (XExpr (ExpandedThingTc (HSE _ e))) + = isCallSite (unLoc e) -- NB: OpApp, SectionL, SectionR are all expanded out isCallSite _ = False @@ -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,14 +660,14 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts)) ListComp -> Just $ BinBox QualBinBox _ -> Nothing -addTickHsExpanded :: HsCtxt -> HsExpr 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 _ -> 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 ===================================== @@ -755,10 +755,10 @@ 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 (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) @@ -1352,8 +1352,8 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where WrapExpr w a -> [ toHie $ L mspan a , toHie (L mspan w) ] - ExpandedThingTc _ e - -> [ toHie (L mspan e) ] + ExpandedThingTc (HSE _ 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,51 @@ 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 o e = XExpr (ExpandedThingRn (HSE o e)) + + +-- | 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 'XXExprGhcTc' +mkExpandedTc o e = XExpr (ExpandedThingTc (HSE 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 - {- ********************************************************************* @@ -1256,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]) @@ -1947,16 +1937,13 @@ 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 - ; 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 @@ -1981,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" $ @@ -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 @@ -46,7 +45,7 @@ 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 :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (HsExpansion GhcRn) expandDoStmts doFlav stmts = expand_do_stmts doFlav stmts -- | The main work horse for expanding do block statements into applications of binds and thens @@ -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) @@ -235,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 @@ -424,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 @@ -482,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 = e} +mkExpandedPatRn pat e = mkExpandedRn (StmtErrCtxtPat pat) (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') } @@ -321,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 = tcXExpr hse res_ty +tcExpr e@(XExpr{}) res_ty = tcApp e res_ty -- Typecheck an occurrence of an unbound Id -- @@ -562,7 +558,22 @@ 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' <- expandDoStmts do_or_lc (unLoc stmts) + ; tcLExpr expr' res_ty } + | MDoExpr{} <- do_or_lc + = do expr' <- expandDoStmts do_or_lc (unLoc stmts) + tcExpr expr' res_ty + | otherwise + -- + = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc x pat cmd) res_ty @@ -678,7 +689,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 $ + ; 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 +787,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,18 +809,23 @@ 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, 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 + 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. @@ -834,16 +850,12 @@ The rest of this Note explains how that is done. -} -tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcXExpr (ExpandedThingRn o e) res_ty +tcXExpr :: HsExpansion GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcXExpr (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 - tcExpr e res_ty - --- For record selection, same as HsVar case -tcXExpr xe res_ty = tcApp (XExpr xe) res_ty - + tcMonoLExpr e res_ty {- ************************************************************************ @@ -1846,3 +1858,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 (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 - (\ (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/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 ===================================== @@ -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) @@ -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 @@ -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 (HSE o _)) <- e' -> addErrCtxt o thing_inside + XExpr (ExpandedThingRn (HSE 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 (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)) - = do e' <- zonkExpr e - return $ XExpr (ExpandedThingTc thing e') +zonkExpr (XExpr (ExpandedThingTc (HSE thing e))) + = do e' <- zonkLExpr e + return $ XExpr (ExpandedThingTc (HSE thing e')) zonkExpr e@(XExpr (ConLikeTc {})) = return e ===================================== 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 ===================================== testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr ===================================== @@ -18,7 +18,9 @@ RecordDotSyntaxFail11.hs:8:11: error: [GHC-39999] • No instance for ‘GHC.Internal.Records.HasField "baz" Int a0’ arising from the record selector ‘foo.bar.baz’ NB: ‘Int’ is not a record type. - • In the expression: (.foo.bar.baz) - In the second argument of ‘($)’, namely ‘(.foo.bar.baz) a’ + • In the second argument of ‘($)’, namely ‘(.foo.bar.baz) a’ In a stmt of a 'do' block: print $ (.foo.bar.baz) a + In the expression: + do let a = Foo {foo = ...} + print $ (.foo.bar.baz) a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/25625e1e23f81193423092ad1f6fbd4... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/25625e1e23f81193423092ad1f6fbd4... You're receiving this email because of your account on gitlab.haskell.org.