[Git][ghc/ghc][wip/spj-apporv-Oct24] make caller wrap the pop err ctxt
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri Oct 18 17:35:34 UTC 2024
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
f697c26c by Apoorv Ingle at 2024-10-18T12:35:02-05:00
make caller wrap the pop err ctxt
- - - - -
3 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Do.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -586,22 +586,6 @@ mkExpandedPatRn
mkExpandedPatRn oPat flav eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigPat oPat flav
, xrn_expanded = eExpr })
--- | Build an expression using the extension constructor `XExpr`,
--- and the two components of the expansion: original do stmt and
--- expanded expression and associate it with a provided location
-mkExpandedStmtAt
- :: Bool -- ^ Wrap this expansion with a pop?
- -> SrcSpanAnnA -- ^ Location for the expansion expression
- -> ExprLStmt GhcRn -- ^ source statement
- -> HsDoFlavour -- ^ the flavour of the statement
- -> HsExpr GhcRn -- ^ expanded expression
- -> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt addPop loc oStmt flav eExpr
- | addPop
- = mkPopErrCtxtExprAt loc (L loc $ mkExpandedStmt oStmt flav eExpr)
- | otherwise
- = L loc $ mkExpandedStmt oStmt flav eExpr
-
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
HsWrapper (HsExpr GhcTc)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -2258,7 +2258,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
-- Need 'pureAName' and not 'returnMName' here, so that it requires
-- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed).
(pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
- let expr = noLocA (HsApp noExtField (noLocA ret) tup)
+ let expr = noLocA (HsApp noExtField (noLocA pure_name) tup)
return (expr, emptyFVs)
return ( ApplicativeArgMany
{ xarg_app_arg_many = noExtField
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -47,7 +47,7 @@ import Data.List ((\\))
* *
************************************************************************
-}
-
+-- TODO: make caller add the pop error context
-- | Expand the `do`-statments into expressions right after renaming
-- so that they can be typechecked.
-- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary
@@ -63,8 +63,6 @@ expand_do_stmts _ ListComp _ =
pprPanic "expand_do_stmts: impossible happened. ListComp" empty
-- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
-expand_do_stmts _ _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
-
expand_do_stmts _ _ (stmt@(L _ (TransStmt {})):_) =
pprPanic "expand_do_stmts: TransStmt" $ ppr stmt
-- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
@@ -73,13 +71,15 @@ expand_do_stmts _ _ (stmt@(L _ (ParStmt {})):_) =
pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
-- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
-expand_do_stmts addPop flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
+expand_do_stmts _ _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
+
+expand_do_stmts _addPop flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (5) below
-- last statement of a list comprehension, needs to explicitly return it
-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
| NoSyntaxExprRn <- ret_expr
-- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
- = return $ mkExpandedStmtAt addPop loc stmt flav body
+ = return $ mkExpandedStmtAt False loc stmt flav body
| SyntaxExprRn ret <- ret_expr
--
@@ -87,18 +87,18 @@ expand_do_stmts addPop flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_exp
-- return e ~~> return e
-- to make T18324 work
= do let expansion = genHsApp ret (L body_loc body)
- return $ mkExpandedStmtAt addPop loc stmt flav expansion
+ return $ mkExpandedStmtAt False loc stmt flav expansion
-expand_do_stmts addPop doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
+expand_do_stmts _addPop doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
-- stmts ~~> stmts'
-- ------------------------------------------------
-- let x = e ; stmts ~~> let x = e in stmts'
- do expand_stmts <- expand_do_stmts True doFlavour lstmts
- let expansion = genHsLet bs expand_stmts
- return $ mkExpandedStmtAt addPop loc stmt doFlavour expansion
+ do expand_stmts <- expand_do_stmts False doFlavour lstmts
+ let expansion = genPopErrCtxtExpr (wrapGenSpan $ genHsLet bs expand_stmts)
+ return $ mkExpandedStmtAt False loc stmt doFlavour (unLoc expansion)
-expand_do_stmts addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
+expand_do_stmts _addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (2) below
@@ -107,27 +107,27 @@ expand_do_stmts addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
-- _ -> fail "Pattern match failure .."
-- -------------------------------------------------------
-- pat <- e ; stmts ~~> (>>=) e f
- = do expand_stmts <- expand_do_stmts True doFlavour lstmts
+ = do expand_stmts <- genPopErrCtxtExpr <$> expand_do_stmts False doFlavour lstmts
failable_expr <- mk_failable_expr False doFlavour pat expand_stmts fail_op
let expansion = genHsExpApps bind_op -- (>>=)
[ e
, failable_expr ]
- return $ mkExpandedStmtAt addPop loc stmt doFlavour expansion
+ return $ mkExpandedStmtAt False loc stmt doFlavour expansion
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
-expand_do_stmts addPop doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
+expand_do_stmts _addPop doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
-- See Note [BodyStmt] in Language.Haskell.Syntax.Expr
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below
-- stmts ~~> stmts'
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
- do expand_stmts_expr <- expand_do_stmts True doFlavour lstmts
+ do expand_stmts_expr <- expand_do_stmts False doFlavour lstmts
let expansion = genHsExpApps then_op -- (>>)
- [ e
- , expand_stmts_expr ]
- return $ mkExpandedStmtAt addPop loc stmt doFlavour expansion
+ [ e
+ , wrapGenSpan (mkPopErrCtxtExpr expand_stmts_expr) ]
+ return $ mkExpandedStmtAt False loc stmt doFlavour expansion
expand_do_stmts _ doFlavour
((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -149,7 +149,7 @@ expand_do_stmts _ doFlavour
-- -> do { rec_stmts
-- ; return (local_only_ids ++ later_ids) } ))
-- (\ [ local_only_ids ++ later_ids ] -> stmts')
- do expand_stmts <- expand_do_stmts True doFlavour lstmts
+ do expand_stmts <- expand_do_stmts False doFlavour lstmts
-- NB: No need to wrap the expansion with an ExpandedStmt
-- as we want to flatten the rec block statements into its parent do block anyway
return $ mkHsApps (wrapGenSpan bind_fun) -- (>>=)
@@ -177,7 +177,7 @@ expand_do_stmts _ doFlavour
-- NB: LazyPat because we do not want to eagerly evaluate the pattern
-- and potentially loop forever
-expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
+expand_do_stmts _addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
-- See Note [Applicative BodyStmt]
--
-- stmts ~~> stmts'
@@ -216,7 +216,7 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
{ xarg_app_arg_one = mb_fail_op
, app_arg_pattern = pat
, arg_expr = (L rhs_loc rhs) }) =
- do let xx_expr = mkExpandedStmtAt addPop (noAnnSrcSpan generatedSrcSpan) stmt doFlavour rhs
+ do let xx_expr = mkExpandedStmtAt False (noAnnSrcSpan generatedSrcSpan) stmt doFlavour rhs
traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
return ((pat, mb_fail_op)
, xx_expr)
@@ -225,13 +225,13 @@ expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join)
, final_expr = ret@(L ret_loc _)
, bv_pattern = pat
, stmt_context = ctxt }) =
- do { xx_expr <- (wrapGenSpan . unLoc) <$> (expand_do_stmts addPop ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret])
- ; traceTc "do_arg" (text "ManyArg" <+> ppr addPop <+> vcat [ppr (stmts ++ [L ret_loc $ mkLastStmt ret]), text "--", ppr xx_expr])
+ do { xx_expr <- (wrapGenSpan . unLoc) <$> (expand_do_stmts False ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret])
+ ; traceTc "do_arg" (text "ManyArg" <+> ppr False <+> vcat [ppr (stmts ++ [L ret_loc $ mkLastStmt ret]), text "--", ppr xx_expr])
; return ((pat, Nothing)
, xx_expr) }
match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
- match_args (pat, fail_op) body = mk_failable_expr addPop doFlavour pat body fail_op
+ match_args (pat, fail_op) body = mk_failable_expr False doFlavour pat body fail_op
mk_apps :: LHsExpr GhcRn -> (SyntaxExprRn, LHsExpr GhcRn) -> LHsExpr GhcRn
mk_apps l_expr (op, r_expr) =
@@ -243,7 +243,7 @@ expand_do_stmts _ _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (p
-- checks the pattern `pat` for irrefutability which decides if we need to wrap it with a fail block
mk_failable_expr :: Bool -> HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
-mk_failable_expr addPop doFlav lpat@(L loc pat) expr@(L exprloc _) fail_op =
+mk_failable_expr _addPop doFlav lpat@(L loc pat) expr@(L _exprloc _) fail_op =
do { is_strict <- xoptM LangExt.Strict
; hscEnv <- getTopEnv
; rdrEnv <- getGlobalRdrEnv
@@ -252,13 +252,11 @@ mk_failable_expr addPop doFlav lpat@(L loc pat) expr@(L exprloc _) fail_op =
; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat
, text "isIrrefutable:" <+> ppr irrf_pat
])
- ; let xexpr | addPop = mkPopErrCtxtExprAt exprloc expr
- | otherwise = expr
; if irrf_pat -- don't wrap with fail block if
-- the pattern is irrefutable
then case pat of
- (WildPat{}) -> return $ genHsLamDoExp doFlav [L noSrcSpanA pat] xexpr
- _ -> return $ genHsLamDoExp doFlav [lpat] xexpr
+ (WildPat{}) -> return $ genHsLamDoExp doFlav [L noSrcSpanA pat] expr
+ _ -> return $ genHsLamDoExp doFlav [lpat] expr
else L loc <$> mk_fail_block doFlav lpat expr fail_op
}
@@ -343,10 +341,10 @@ 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 (‹PopExprCtxt›(\ p -> DO【 ss 】))
+ (>>=) s ((\ p -> ‹PopExprCtxt› DO【 ss 】))
else ‹ExpansionStmt (p <- e)›
- (>>=) s (‹PopExprCtxt›(\case p -> DO【 ss 】
- _ -> fail "pattern p failure"))
+ (>>=) s ((\case p -> ‹PopExprCtxt› DO【 ss 】
+ _ -> fail "pattern p failure"))
(3) DO【 let x = e; ss 】
= ‹ExpansionStmt (let x = e)› (let x = e in (‹PopErrCtxt›DO【 ss 】))
@@ -573,7 +571,6 @@ mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)
mkPopErrCtxtExprAt :: SrcSpanAnnA -> LHsExpr GhcRn -> LHsExpr GhcRn
mkPopErrCtxtExprAt _loc a = wrapGenSpan $ mkPopErrCtxtExpr a
-
genPopErrCtxtExpr :: LHsExpr GhcRn -> LHsExpr GhcRn
genPopErrCtxtExpr a = wrapGenSpan $ mkPopErrCtxtExpr a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f697c26c1917fb946b9ef59872e362f95c1973f0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f697c26c1917fb946b9ef59872e362f95c1973f0
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/20241018/3bfcb7ea/attachment-0001.html>
More information about the ghc-commits
mailing list