[Git][ghc/ghc][wip/spj-apporv-Oct24] remove HsExprRn from VAExpansion
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Feb 24 08:17:09 UTC 2025
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
9648167a by Apoorv Ingle at 2025-02-24T02:16:44-06:00
remove HsExprRn from VAExpansion
- - - - -
9 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- testsuite/tests/ghci.debugger/scripts/break029.script
- testsuite/tests/ghci.debugger/scripts/break029.stdout
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -638,6 +638,12 @@ mkExpandedStmtTc
-> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
mkExpandedStmtTc oStmt flav eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt flav) eExpr)
+mkExpandedTc
+ :: HsThingRn
+ -> HsExpr GhcTc
+ -> HsExpr GhcTc
+mkExpandedTc o eExpr = XExpr (ExpandedThingTc o eExpr)
+
{- *********************************************************************
* *
Pretty-printing expressions
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -178,10 +178,10 @@ tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType
tcInferSigma inst (L loc rn_expr)
= addExprCtxt rn_expr $
setSrcSpanA loc $
- do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps Nothing rn_expr
+ do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr
; do_ql <- wantQuickLook rn_fun
; (tc_fun, fun_sigma) <- tcInferAppHead fun
- ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt) fun_sigma rn_args
+ ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt, rn_expr) fun_sigma rn_args
; _ <- tcValArgs do_ql inst_args
; return app_res_sigma }
@@ -387,14 +387,13 @@ Unify result type /before/ typechecking the args
The latter is much better. That is why we call checkResultType before tcValArgs.
-}
-tcApp :: Maybe HsThingRn -- Just x <=> Expr is a compiler generated expression for x
- -> HsExpr GhcRn
+tcApp :: HsExpr GhcRn
-> ExpRhoType -- When checking, -XDeepSubsumption <=> deeply skolemised
-> TcM (HsExpr GhcTc)
-- See Note [tcApp: typechecking applications]
-tcApp mb_oexpr rn_expr exp_res_ty
+tcApp rn_expr exp_res_ty
= do { -- Step 1: Split the application chain
- (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps mb_oexpr rn_expr
+ (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr
; traceTc "tcApp {" $
vcat [ text "rn_expr:" <+> ppr rn_expr
, text "rn_fun:" <+> ppr rn_fun
@@ -410,7 +409,7 @@ tcApp mb_oexpr rn_expr exp_res_ty
; (inst_args, app_res_rho)
<- setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in
-- Note [tcApp: typechecking applications]
- tcInstFun do_ql True tc_head fun_sigma rn_args
+ tcInstFun do_ql True (tc_fun, fun_ctxt, rn_expr) fun_sigma rn_args
; case do_ql of
NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho)
@@ -515,7 +514,7 @@ checkResultTy rn_expr (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty)
-- Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
perhaps_add_res_ty_ctxt thing_inside
| insideExpansion fun_ctxt
- = addHeadCtxt fun_ctxt thing_inside
+ = thing_inside
| otherwise
= addFunResCtxt tc_fun inst_args app_res_rho (mkCheckExpType res_ty) $
thing_inside
@@ -644,14 +643,14 @@ tcInstFun :: QLFlag
-- in tcInferSigma, which is used only to implement :type
-- Otherwise we do eager instantiation; in Fig 5 of the paper
-- |-inst returns a rho-type
- -> (HsExpr GhcTc, AppCtxt)
+ -> (HsExpr GhcTc, AppCtxt, HsExpr GhcRn)
-> TcSigmaType -> [HsExprArg 'TcpRn]
-> TcM ( [HsExprArg 'TcpInst]
, TcSigmaType )
-- This crucial function implements the |-inst judgement in Fig 4, plus the
-- modification in Fig 5, of the QL paper:
-- "A quick look at impredicativity" (ICFP'20).
-tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
+tcInstFun do_ql inst_final (tc_fun, fun_ctxt, e) fun_sigma rn_args
= do { traceTc "tcInstFun" (vcat [ text "tc_fun" <+> ppr tc_fun
, text "fun_sigma" <+> ppr fun_sigma
, text "fun_ctxt" <+> ppr fun_ctxt
@@ -660,10 +659,8 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
; go 1 [] fun_sigma rn_args }
where
fun_orig = case fun_ctxt of
- VAExpansion (OrigStmt{}) _ -> DoOrigin
- VAExpansion (OrigPat pat _) _ -> DoPatOrigin pat
- VAExpansion (OrigExpr e) _ -> exprCtOrigin e
- VACall e _ _ -> exprCtOrigin e
+ VAExpansion -> exprCtOrigin e
+ VACall e' _ _ -> exprCtOrigin e'
-- These are the type variables which must be instantiated to concrete
-- types. See Note [Representation-polymorphic Ids with no binding]
@@ -741,7 +738,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
= do { (_inst_tvs, wrap, fun_rho) <-
-- addHeadCtxt: important for the class constraints
-- that may be emitted from instantiating fun_sigma
- addHeadCtxt fun_ctxt $
+
instantiateSigma fun_orig fun_conc_tvs tvs theta body2
-- See Note [Representation-polymorphism checking built-ins]
-- in GHC.Tc.Utils.Concrete.
@@ -906,10 +903,6 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $
thing_inside
- VAExpansion (OrigStmt{}) _
- -> setSrcSpanA arg_loc $
- thing_inside -- Do nothing as we have pushed "In the stmt of .."
-
_ -> setSrcSpanA arg_loc $
addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
thing_inside }
@@ -1722,7 +1715,7 @@ quickLookArg1 :: AppCtxt -> LHsExpr GhcRn
quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
= addArgCtxt ctxt larg $ -- Context needed for constraints
-- generated by calls in arg
- do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps Nothing arg
+ do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg
-- Step 1: get the type of the head of the argument
; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun
@@ -1746,7 +1739,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
; do_ql <- wantQuickLook rn_fun
; ((inst_args, app_res_rho), wanted)
<- captureConstraints $
- tcInstFun do_ql True tc_head fun_sigma rn_args
+ tcInstFun do_ql True (tc_fun, fun_ctxt, arg) fun_sigma rn_args
-- We must capture type-class and equality constraints here, but
-- not equality constraints. See (QLA6) in Note [Quick Look at
-- value arguments]
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -335,9 +335,9 @@ They capture the essence of statement expansions as implemented in `expand_do_st
(2) DO【 p <- e; ss 】 = if p is irrefutable
then ‹ExpansionStmt (p <- e)›
- (>>=) s ((\ p -> ‹PopExprCtxt› DO【 ss 】))
+ (>>=) e ((\ p -> ‹PopExprCtxt› DO【 ss 】))
else ‹ExpansionStmt (p <- e)›
- (>>=) s ((\case p -> ‹PopExprCtxt› DO【 ss 】
+ (>>=) e ((\case p -> ‹PopExprCtxt› DO【 ss 】
_ -> fail "pattern p failure"))
(3) DO【 let x = e; ss 】
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -128,7 +128,7 @@ tcPolyLExprNC (L loc expr) res_ty
-----------------
tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
-tcPolyExpr e (Infer inf) = tcExpr Nothing e (Infer inf)
+tcPolyExpr e (Infer inf) = tcExpr e (Infer inf)
tcPolyExpr e (Check ty) = tcPolyExprCheck e (Left ty)
-----------------
@@ -185,7 +185,7 @@ tcPolyExprCheck expr res_ty
-- before handing off to tcExpr
tc_body e = do { ds_flag <- getDeepSubsumptionFlag
; inner_skolemise ds_flag rho_ty $ \rho_ty' ->
- tcExpr Nothing e (mkCheckExpType rho_ty') }
+ tcExpr e (mkCheckExpType rho_ty') }
in tc_body expr
where
-- `outer_skolemise` is used always
@@ -230,12 +230,12 @@ tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
tcInferRho (L loc expr)
= setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
addExprCtxt expr $ -- Note [Error contexts in generated code]
- do { (expr', rho) <- tcInfer (tcExpr Nothing expr)
+ do { (expr', rho) <- tcInfer (tcExpr expr)
; return (L loc expr', rho) }
tcInferRhoNC (L loc expr)
= setSrcSpanA loc $
- do { (expr', rho) <- tcInfer (tcExpr Nothing expr)
+ do { (expr', rho) <- tcInfer (tcExpr expr)
; return (L loc expr', rho) }
---------------
@@ -257,17 +257,16 @@ tcMonoExpr, tcMonoExprNC
tcMonoExpr (L loc expr) res_ty
= setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
addExprCtxt expr $ -- Note [Error contexts in generated code]
- do { expr' <- tcExpr Nothing expr res_ty
+ do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
tcMonoExprNC (L loc expr) res_ty
= setSrcSpanA loc $
- do { expr' <- tcExpr Nothing expr res_ty
+ do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
---------------
-tcExpr :: Maybe HsThingRn
- -> HsExpr GhcRn
+tcExpr :: HsExpr GhcRn
-> ExpRhoType -- DeepSubsumption <=> when checking, this type
-- is deeply skolemised
-> TcM (HsExpr GhcTc)
@@ -288,45 +287,45 @@ tcExpr :: Maybe HsThingRn
-- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps
-- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
-tcExpr xern e@(HsVar {}) res_ty = tcApp xern e res_ty
-tcExpr xern e@(HsApp {}) res_ty = tcApp xern e res_ty
-tcExpr xern e@(OpApp {}) res_ty = tcApp xern e res_ty
-tcExpr xern e@(HsAppType {}) res_ty = tcApp xern e res_ty
-tcExpr xern e@(ExprWithTySig {}) res_ty = tcApp xern e res_ty
+tcExpr e@(HsVar {}) res_ty = tcApp e res_ty
+tcExpr e@(HsApp {}) res_ty = tcApp e res_ty
+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 e) res_ty = tcXExpr e res_ty
-- Typecheck an occurrence of an unbound Id
--
-- Some of these started life as a true expression hole "_".
-- Others might simply be variables that accidentally have no binding site
-tcExpr _ (HsUnboundVar _ occ) res_ty
+tcExpr (HsUnboundVar _ occ) res_ty
= do { ty <- expTypeToType res_ty -- Allow Int# etc (#12531)
; her <- emitNewExprHole occ ty
; tcEmitBindingUsage bottomUE -- Holes fit any usage environment
-- (#18491)
; return (HsUnboundVar her occ) }
-tcExpr _ e@(HsLit x lit) res_ty
+tcExpr e@(HsLit x lit) res_ty
= do { let lit_ty = hsLitType lit
; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }
-tcExpr _ (HsPar x expr) res_ty
+tcExpr (HsPar x expr) res_ty
= do { expr' <- tcMonoExprNC expr res_ty
; return (HsPar x expr') }
-tcExpr _ (HsPragE x prag expr) res_ty
+tcExpr (HsPragE x prag expr) res_ty
= do { expr' <- tcMonoExpr expr res_ty
; return (HsPragE x (tcExprPrag prag) expr') }
-tcExpr _ (NegApp x expr neg_expr) res_ty
+tcExpr (NegApp x expr neg_expr) res_ty
= do { (expr', neg_expr')
<- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
\[arg_ty] [arg_mult] ->
tcScalingUsage arg_mult $ tcCheckMonoExpr expr arg_ty
; return (NegApp x expr' neg_expr') }
-tcExpr _ e@(HsIPVar _ x) res_ty
+tcExpr e@(HsIPVar _ x) res_ty
= do { ip_ty <- newFlexiTyVarTy liftedTypeKind
-- Create a unification type variable of kind 'Type'.
-- (The type of an implicit parameter must have kind 'Type'.)
@@ -342,7 +341,7 @@ tcExpr _ e@(HsIPVar _ x) res_ty
unwrapIP $ mkClassPred ipClass [x,ty]
origin = IPOccOrigin x
-tcExpr _ e@(HsLam x lam_variant matches) res_ty
+tcExpr e@(HsLam x lam_variant matches) res_ty
= do { (wrap, matches') <- tcLambdaMatches e lam_variant matches [] res_ty
; return (mkHsWrap wrap $ HsLam x lam_variant matches') }
@@ -354,13 +353,13 @@ tcExpr _ e@(HsLam x lam_variant matches) res_ty
************************************************************************
-}
-tcExpr _ e@(HsOverLit _ lit) res_ty
+tcExpr e@(HsOverLit _ lit) res_ty
= -- See Note [Typechecking overloaded literals]
do { mb_res <- tcShortCutLit lit res_ty
-- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.TcMType
; case mb_res of
Just lit' -> return (HsOverLit noExtField lit')
- Nothing -> tcApp Nothing e res_ty }
+ Nothing -> tcApp e res_ty }
-- Why go via tcApp? See Note [Typechecking overloaded literals]
{- Note [Typechecking overloaded literals]
@@ -403,14 +402,14 @@ tricky:
-- The expansion includes an ExplicitList, but it is always the built-in
-- list type, so that's all we need concern ourselves with here. See
-- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs]
-tcExpr _ (ExplicitList _ exprs) res_ty
+tcExpr (ExplicitList _ exprs) res_ty
= do { res_ty <- expTypeToType res_ty
; (coi, elt_ty) <- matchExpectedListTy res_ty
; let tc_elt expr = tcCheckPolyExpr expr elt_ty
; exprs' <- mapM tc_elt exprs
; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' }
-tcExpr _ expr@(ExplicitTuple x tup_args boxity) res_ty
+tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
| all tupArgPresent tup_args
= do { let arity = length tup_args
tup_tc = tupleTyCon boxity arity
@@ -441,7 +440,7 @@ tcExpr _ expr@(ExplicitTuple x tup_args boxity) res_ty
; tcWrapResultMono expr expr' act_res_ty res_ty }
-tcExpr _ (ExplicitSum _ alt arity expr) res_ty
+tcExpr (ExplicitSum _ alt arity expr) res_ty
= do { let sum_tc = sumTyCon arity
; res_ty <- expTypeToType res_ty
; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
@@ -468,12 +467,12 @@ tcExpr _ (ExplicitSum _ alt arity expr) res_ty
************************************************************************
-}
-tcExpr _ (HsLet x binds expr) res_ty
+tcExpr (HsLet x binds expr) res_ty
= do { (binds', expr') <- tcLocalBinds binds $
tcMonoExpr expr res_ty
; return (HsLet x binds' expr') }
-tcExpr _ (HsCase ctxt scrut matches) res_ty
+tcExpr (HsCase ctxt scrut matches) res_ty
= do { -- We used to typecheck the case alternatives first.
-- The case patterns tend to give good type info to use
-- when typechecking the scrutinee. For example
@@ -497,7 +496,7 @@ tcExpr _ (HsCase ctxt scrut matches) res_ty
; matches' <- tcCaseMatches tcBody (Scaled mult scrut_ty) matches res_ty
; return (HsCase ctxt scrut' matches') }
-tcExpr _ (HsIf x pred b1 b2) res_ty
+tcExpr (HsIf x pred b1 b2) res_ty
= do { pred' <- tcCheckMonoExpr pred boolTy
; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty
; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty
@@ -528,16 +527,16 @@ If we add linear guards, this code will have to be revisited.
Not using 'sup' caused #23814.
-}
-tcExpr _ (HsMultiIf _ alts) res_ty
+tcExpr (HsMultiIf _ alts) res_ty
= do { alts' <- tcGRHSList IfAlt tcBody alts res_ty
-- See Note [MultiWayIf linearity checking]
; res_ty <- readExpType res_ty
; return (HsMultiIf res_ty alts') }
-tcExpr _ (HsDo _ do_or_lc stmts) res_ty
+tcExpr (HsDo _ do_or_lc stmts) res_ty
= tcDoStmts do_or_lc stmts res_ty
-tcExpr _ (HsProc x pat cmd) res_ty
+tcExpr (HsProc x pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
; return $ mkHsWrapCo coi (HsProc x pat' cmd') }
@@ -549,7 +548,7 @@ tcExpr _ (HsProc x pat cmd) res_ty
-- and wrap (static e) in a call to
-- fromStaticPtr :: IsStatic p => StaticPtr a -> p a
-tcExpr _ (HsStatic fvs expr) res_ty
+tcExpr (HsStatic fvs expr) res_ty
= do { res_ty <- expTypeToType res_ty
; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
; (expr', lie) <- captureConstraints $
@@ -584,10 +583,10 @@ tcExpr _ (HsStatic fvs expr) res_ty
(L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr'))
}
-tcExpr _ (HsEmbTy _ _) _ = failWith (TcRnIllegalTypeExpr TypeKeywordSyntax)
-tcExpr _ (HsQual _ _ _) _ = failWith (TcRnIllegalTypeExpr ContextArrowSyntax)
-tcExpr _ (HsForAll _ _ _) _ = failWith (TcRnIllegalTypeExpr ForallTelescopeSyntax)
-tcExpr _ (HsFunArr _ _ _ _) _ = failWith (TcRnIllegalTypeExpr FunctionArrowSyntax)
+tcExpr (HsEmbTy _ _) _ = failWith (TcRnIllegalTypeExpr TypeKeywordSyntax)
+tcExpr (HsQual _ _ _) _ = failWith (TcRnIllegalTypeExpr ContextArrowSyntax)
+tcExpr (HsForAll _ _ _) _ = failWith (TcRnIllegalTypeExpr ForallTelescopeSyntax)
+tcExpr (HsFunArr _ _ _ _) _ = failWith (TcRnIllegalTypeExpr FunctionArrowSyntax)
{-
************************************************************************
@@ -597,7 +596,7 @@ tcExpr _ (HsFunArr _ _ _ _) _ = failWith (TcRnIllegalTypeExpr FunctionArrowSynta
************************************************************************
-}
-tcExpr _ expr@(RecordCon { rcon_con = L loc con_name
+tcExpr expr@(RecordCon { rcon_con = L loc con_name
, rcon_flds = rbinds }) res_ty
= do { con_like <- tcLookupConLike con_name
@@ -638,7 +637,7 @@ tcExpr _ expr@(RecordCon { rcon_con = L loc con_name
-- in the renamer. See Note [Overview of record dot syntax] in
-- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here
-- and panic otherwise.
-tcExpr _ expr@(RecordUpd { rupd_expr = record_expr
+tcExpr expr@(RecordUpd { rupd_expr = record_expr
, rupd_flds =
RegularRecUpdFields
{ xRecUpdFields = possible_parents
@@ -652,7 +651,7 @@ tcExpr _ expr@(RecordUpd { rupd_expr = record_expr
-- Typecheck the expanded expression.
; expr' <- addErrCtxt err_ctxt $
- tcExpr Nothing (mkExpandedExpr expr ds_expr) (Check ds_res_ty)
+ tcExpr (mkExpandedExpr expr ds_expr) (Check ds_res_ty)
-- NB: it's important to use ds_res_ty and not res_ty here.
-- Test case: T18802b.
@@ -664,7 +663,7 @@ tcExpr _ expr@(RecordUpd { rupd_expr = record_expr
-- Test case: T10808.
}
-tcExpr _ e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {}}) _
+tcExpr e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {}}) _
= pprPanic "tcExpr: unexpected overloaded-dot RecordUpd" $ ppr e
{-
@@ -677,7 +676,7 @@ tcExpr _ e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {}}) _
************************************************************************
-}
-tcExpr _ (ArithSeq _ witness seq) res_ty
+tcExpr (ArithSeq _ witness seq) res_ty
= tcArithSeq witness seq res_ty
{-
@@ -690,8 +689,8 @@ tcExpr _ (ArithSeq _ witness seq) res_ty
-- These terms have been replaced by their expanded expressions in the renamer. See
-- Note [Overview of record dot syntax].
-tcExpr _ (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
-tcExpr _ (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
+tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
+tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
{-
************************************************************************
@@ -703,11 +702,11 @@ tcExpr _ (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: No
-- Here we get rid of it and add the finalizers to the global environment.
-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
-tcExpr _ (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty
-tcExpr _ e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty
+tcExpr (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty
+tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty
-tcExpr _ e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty
-tcExpr _ (HsUntypedSplice splice _) res_ty
+tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty
+tcExpr (HsUntypedSplice splice _) res_ty
-- Since `tcApp` deals with `HsUntypedSplice` (in `splitHsApps`), you might
-- wonder why we don't delegate to `tcApp` as we do for `HsVar`, etc.
-- (See the initial block of equations for `tcExpr`.) But we can't do this
@@ -715,7 +714,7 @@ tcExpr _ (HsUntypedSplice splice _) res_ty
-- Note [Looking through Template Haskell splices in splitHsApps] in
-- GHC.Tc.Gen.Head.
= do { expr <- getUntypedSpliceBody splice
- ; tcExpr Nothing expr res_ty }
+ ; tcExpr expr res_ty }
{-
************************************************************************
@@ -725,9 +724,9 @@ tcExpr _ (HsUntypedSplice splice _) res_ty
************************************************************************
-}
-tcExpr _ (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty)
-tcExpr _ (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty)
-tcExpr _ (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
+tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty)
+tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty)
+tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
{-
@@ -742,15 +741,16 @@ tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcXExpr (PopErrCtxt e) res_ty
= popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`
- tcExpr Nothing e res_ty
+ tcExpr e res_ty
-tcXExpr (ExpandedThingRn o@(OrigStmt stmt flav) e) res_ty
+tcXExpr (ExpandedThingRn o e) res_ty
= addThingCtxt o $
- mkExpandedStmtTc stmt flav <$> -- necessary for breakpoints
- tcExpr (Just o) e res_ty
+ mkExpandedTc o <$> -- necessary for breakpoints
+ (setInGeneratedCode $
+ tcExpr e res_ty)
-- For record selection, etc
-tcXExpr xe res_ty = tcApp Nothing (XExpr xe) res_ty
+tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
{-
=====================================
compiler/GHC/Tc/Gen/Expr.hs-boot
=====================================
@@ -1,6 +1,6 @@
module GHC.Tc.Gen.Expr where
import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn
- , SyntaxExprTc, HsThingRn )
+ , SyntaxExprTc )
import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR
, SyntaxOpType
, ExpType, ExpRhoType, ExpSigmaType )
@@ -9,7 +9,7 @@ import GHC.Tc.Types.BasicTypes( TcCompleteSig )
import GHC.Tc.Types.Origin ( CtOrigin )
import GHC.Core.Type ( Mult )
import GHC.Hs.Extension ( GhcRn, GhcTc )
-import GHC.Prelude ( Maybe )
+
tcCheckPolyExpr, tcCheckPolyExprNC ::
LHsExpr GhcRn
-> TcSigmaType
@@ -28,7 +28,7 @@ tcPolyLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc)
tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc)
tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
-tcExpr :: Maybe HsThingRn -> HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcInferRho, tcInferRhoNC ::
LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -28,7 +28,7 @@ module GHC.Tc.Gen.Head
, nonBidirectionalErr
, pprArgInst
- , addHeadCtxt, addThingCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where
+ , addThingCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )
import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody )
@@ -210,8 +210,8 @@ data EWrap = EPar AppCtxt
data AppCtxt
= VAExpansion
- HsThingRn
- SrcSpan
+ -- HsThingRn
+ -- SrcSpan
| VACall
(HsExpr GhcRn) Int -- In the third argument of function f
@@ -247,11 +247,11 @@ a second time.
-}
appCtxtLoc :: AppCtxt -> SrcSpan
-appCtxtLoc (VAExpansion _ l) = l
+appCtxtLoc (VAExpansion) = generatedSrcSpan
appCtxtLoc (VACall _ _ l) = l
insideExpansion :: AppCtxt -> Bool
-insideExpansion (VAExpansion {}) = True
+insideExpansion (VAExpansion) = True
insideExpansion (VACall _ _ loc) = isGeneratedSrcSpan loc
instance Outputable QLFlag where
@@ -259,7 +259,7 @@ instance Outputable QLFlag where
ppr NoQL = text "NoQL"
instance Outputable AppCtxt where
- ppr (VAExpansion e l) = text "VAExpansion" <+> ppr e <+> ppr l
+ ppr (VAExpansion) = text "VAExpansion"
ppr (VACall f n l) = text "VACall" <+> int n <+> ppr f <+> ppr l
type family XPass (p :: TcPass) where
@@ -282,8 +282,7 @@ addArgWrap wrap args
| isIdHsWrapper wrap = args
| otherwise = EWrap (EHsWrap wrap) : args
-splitHsApps :: Maybe HsThingRn
- -> HsExpr GhcRn
+splitHsApps :: HsExpr GhcRn
-> TcM ( (HsExpr GhcRn, AppCtxt) -- Head
, [HsExprArg 'TcpRn]) -- Args
-- See Note [splitHsApps].
@@ -291,25 +290,25 @@ splitHsApps :: Maybe HsThingRn
-- This uses the TcM monad solely because we must run modFinalizers when looking
-- through HsUntypedSplices
-- (see Note [Looking through Template Haskell splices in splitHsApps]).
-splitHsApps mb_oexpr e = go e (top_ctxt mb_oexpr 0 e) []
+splitHsApps e = do inGenCode <- inGeneratedCode
+ if inGenCode
+ then go e VAExpansion []
+ else go e (top_ctxt 0 e) []
where
- top_ctxt :: Maybe HsThingRn -> Int -> HsExpr GhcRn -> AppCtxt
- -- Always returns VACall fun n_val_args noSrcSpan
+ top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt
+ -- Always returns VACall fun n_val_args noSrcSpanA
-- to initialise the argument splitting in 'go'
-- See Note [AppCtxt]
- top_ctxt (Just (OrigStmt (L _ LastStmt{}) _)) n fun = top_ctxt Nothing n fun
- top_ctxt (Just x@(OrigStmt (L l _) _)) _ _ = VAExpansion x (locA l)
- top_ctxt (Just x) _ _ = VAExpansion x generatedSrcSpan
+ top_ctxt n (HsPar _ fun) = top_lctxt n fun
+ top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun
+ top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun
+ top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
+ top_ctxt n other_fun = VACall other_fun n noSrcSpan
- top_ctxt _ n (HsPar _ fun) = top_lctxt n fun
- top_ctxt _ n (HsPragE _ _ fun) = top_lctxt n fun
- top_ctxt _ n (HsAppType _ fun _) = top_lctxt (n+1) fun
- top_ctxt _ n (HsApp _ fun _) = top_lctxt (n+1) fun
- top_ctxt _ n (XExpr (ExpandedThingRn (OrigExpr fun) _))
- = VACall fun n noSrcSpan
- top_ctxt _ n other_fun = VACall other_fun n noSrcSpan
-
- top_lctxt n (L _ fun) = top_ctxt Nothing n fun
+ top_lctxt :: Int -> LHsExpr GhcRn -> AppCtxt
+ top_lctxt n (L l fun) = if isGeneratedSrcSpan (locA l)
+ then VAExpansion
+ else top_ctxt n fun
go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
-> TcM ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
@@ -330,9 +329,9 @@ splitHsApps mb_oexpr e = go e (top_ctxt mb_oexpr 0 e) []
HsQuasiQuote _ _ (L l _) -> set l ctxt -- l :: SrcAnn NoEpAnns
-- See Note [Looking through ExpandedThingRn]
- go (XExpr (ExpandedThingRn o e)) ctxt args
- = go e (VAExpansion o (appCtxtLoc ctxt))
- (EWrap (EExpand o) : args)
+ -- go (XExpr (ExpandedThingRn o e)) ctxt args
+ -- = go e (VAExpansion)
+ -- (EWrap (EExpand o) : args)
-- See Note [Desugar OpApp in the typechecker]
go e@(OpApp _ arg1 (L l op) arg2) _ args
@@ -539,12 +538,11 @@ tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
-- cases are dealt with by splitHsApps.
--
-- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App
-tcInferAppHead (fun,ctxt)
- = addHeadCtxt ctxt $
- do { mb_tc_fun <- tcInferAppHead_maybe fun
+tcInferAppHead (fun,_)
+ = do { mb_tc_fun <- tcInferAppHead_maybe fun
; case mb_tc_fun of
Just (fun', fun_sigma) -> return (fun', fun_sigma)
- Nothing -> tcInfer (tcExpr Nothing fun) }
+ Nothing -> tcInfer (tcExpr fun) }
tcInferAppHead_maybe :: HsExpr GhcRn
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
@@ -558,19 +556,6 @@ tcInferAppHead_maybe fun
HsOverLit _ lit -> Just <$> tcInferOverLit lit
_ -> return Nothing
-addHeadCtxt :: AppCtxt -> TcM a -> TcM a
-addHeadCtxt fun_ctxt thing_inside
- | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
- = thing_inside -- => context is already set
- | otherwise
- = setSrcSpan fun_loc $
- do case fun_ctxt of
- VAExpansion (OrigExpr orig) _
- -> addExprCtxt orig thing_inside
- _ -> thing_inside
- where
- fun_loc = appCtxtLoc fun_ctxt
-
{- *********************************************************************
* *
@@ -1246,19 +1231,19 @@ mis-match in the number of value arguments.
* *
********************************************************************* -}
-
-addStmtCtxt :: ExprStmt GhcRn -> HsDoFlavour -> TcRn a -> TcRn a
-addStmtCtxt stmt flav =
- addErrCtxt (StmtErrCtxt (HsDoStmt flav) stmt)
-
addThingCtxt :: HsThingRn -> TcRn a -> TcRn a
-
addThingCtxt (OrigStmt (L loc stmt) flav) thing_inside = do
setSrcSpanA loc $
addStmtCtxt stmt flav $
thing_inside
--- addThingCtxt (OrigExpr e) thing_inside = addExprCtxt e thing_inside
-addThingCtxt _ thing_inside = thing_inside
+addThingCtxt (OrigExpr e) thing_inside = addExprCtxt e thing_inside
+addThingCtxt (OrigPat (L loc p) _) thing_inside =
+ do setSrcSpanA loc $
+ addErrCtxt (PatCtxt p) thing_inside
+
+addStmtCtxt :: ExprStmt GhcRn -> HsDoFlavour -> TcRn a -> TcRn a
+addStmtCtxt stmt flav =
+ addErrCtxt (StmtErrCtxt (HsDoStmt flav) stmt)
addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -345,13 +345,13 @@ tcDoStmts ListComp (L l stmts) res_ty
tcDoStmts doExpr@(DoExpr _) ss@(L _ stmts) res_ty
= do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly
; let orig = HsDo noExtField doExpr ss
- ; mkExpandedExprTc orig <$> tcExpr (Just (OrigExpr orig)) expanded_expr res_ty
+ ; mkExpandedExprTc orig <$> tcExpr expanded_expr res_ty
}
tcDoStmts mDoExpr@(MDoExpr _) ss@(L _ stmts) res_ty
= do { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly
; let orig = HsDo noExtField mDoExpr ss
- ; mkExpandedExprTc orig <$> tcExpr (Just (OrigExpr orig)) expanded_expr res_ty }
+ ; mkExpandedExprTc orig <$> tcExpr expanded_expr res_ty }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
=====================================
testsuite/tests/ghci.debugger/scripts/break029.script
=====================================
@@ -1,4 +1,5 @@
:load break029.hs
:step f 3
:step
+:step
y
=====================================
testsuite/tests/ghci.debugger/scripts/break029.stdout
=====================================
@@ -6,5 +6,6 @@ _result :: Int = _
y :: Int = _
Stopped in Main.f, break029.hs:6:11-15
_result :: Int = _
+
y :: Int = _
4
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9648167a936a329d3876de71235f476e5836ddf8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9648167a936a329d3876de71235f476e5836ddf8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250224/0959562c/attachment-0001.html>
More information about the ghc-commits
mailing list