[Git][ghc/ghc][wip/expand-do] use mkExpandStmt to store original stmts along with expanded expr for using...
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Thu May 25 02:01:51 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
0a3e438d by Apoorv Ingle at 2023-05-24T21:01:39-05:00
use mkExpandStmt to store original stmts along with expanded expr for using the right context for error message printing
- - - - -
5 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Module.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -752,8 +752,10 @@ ppr_expr (XExpr x) = case ghcPass @p of
GhcTc -> ppr x
instance Outputable XXExprGhcRn where
- ppr (ExpansionExprRn (HsExpanded (Left o) e)) = ppr (HsExpanded o e)
- ppr (ExpansionExprRn (HsExpanded (Right o) e)) = ppr (HsExpanded o e)
+ ppr (ExpansionExprRn ex@(HsExpanded (Left o) e)) = ifPprDebug (text "ExpansionExprRn" <+> ppr ex)
+ (ppr (HsExpanded o e))
+ ppr (ExpansionExprRn ex@(HsExpanded (Right o) e)) = ifPprDebug (text "ExpansionExprRn" <+> ppr ex)
+ (ppr (HsExpanded o e))
ppr (PopSrcSpan e) = ifPprDebug (text "PopSrcSpan" <+> ppr e)
(ppr e)
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -867,7 +867,7 @@ warnUnusedBindValue fun arg@(L loc _) arg_ty
])
putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
where
- -- retrieve the location info and the head of the application
+ -- Retrieve the location info and the head of the application
-- It is important that we /do not/ look through HsApp to avoid
-- generating duplicate warnings
fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module Language.Haskell.Syntax.Extension
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -206,7 +207,7 @@ 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 e@(HsRecSel {}) res_ty = tcApp e res_ty
-tcExpr e@(XExpr (ExpansionExprRn (HsExpanded {}))) res_ty = tcApp e res_ty
+tcExpr e@(XExpr (ExpansionExprRn (HsExpanded (Left _) _))) res_ty = tcApp e res_ty
tcExpr e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
@@ -408,6 +409,11 @@ tcExpr (HsMultiIf _ alts) res_ty
; return (HsMultiIf res_ty alts') }
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
+tcExpr (XExpr (ExpansionExprRn (HsExpanded (Right stmt) expr))) res_ty
+ = do { addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
+ tcExpr expr res_ty
+ }
+
tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
= do { expand_expr <- expandDoStmts doFlav stmts
-- Do expansion on the fly
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1192,38 +1192,36 @@ expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
expand_do_stmts ListComp _ = pprPanic "expand_do_stmts: impossible happened. ListComp" empty
expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
-expand_do_stmts _ [L loc (LastStmt _ body _ ret_expr)]
+expand_do_stmts _ [stmt@(L _ (LastStmt _ body _ ret_expr))]
-- last statement of a list comprehension, needs to explicitly return it
-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
- -- TODO: i don't think we need this if we never call from a ListComp
- -- ListComp <- do_flavour
- -- = return $ noLocA (genHsApp (genHsVar returnMName) body)
| NoSyntaxExprRn <- ret_expr
-- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
- = return body
+ = return (noLocA (mkExpandedStmt stmt (unLoc body)))
| SyntaxExprRn ret <- ret_expr
--
-- ------------------------------------------------
-- return e ~~> return e
-- to make T18324 work
- = return $ L loc (genHsApp ret body)
+ = return $ noLocA (mkExpandedStmt stmt (genHsApp ret body))
expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn =
--- the pattern binding x can fail
+-- the pattern binding pat can fail
-- instead of making an internal name, the fail block is just an anonymous match block
--- stmts ~~> stmt' expr = let / pat = stmts';
--- _ = fail "Pattern match failure .."
+-- stmts ~~> stmt' f = / -> pat = stmts';
+-- _ = fail "Pattern match failure .."
-- -------------------------------------------------------
--- pat <- e ; stmts ~~> (>>=) expr f
+-- pat <- e ; stmts ~~> (>>=) e f
do expand_stmts <- expand_do_stmts do_or_lc lstmts
expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
- return $ mkHsApps (wrapGenSpan bind_op) -- (>>=)
- [ e
- , genPopSrcSpanExpr expr
- ]
+ return $ noLocA (mkExpandedStmt stmt
+ (unLoc $ mkHsApps (wrapGenSpan bind_op) -- (>>=)
+ [ e
+ , genPopSrcSpanExpr expr
+ ]))
| otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
@@ -1235,15 +1233,16 @@ expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
return $ wrapGenSpan (HsLet noExtField noHsTok bnds noHsTok (genPopSrcSpanExpr expand_stmts))
-expand_do_stmts do_or_lc ((L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
+expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
-- See Note [BodyStmt]
-- stmts ~~> stmts'
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ (mkHsApps (wrapGenSpan f) -- (>>)
- [ e -- e
- , genPopSrcSpanExpr expand_stmts ]) -- stmts'
+ return $ noLocA (mkExpandedStmt stmt
+ (unLoc $ mkHsApps (wrapGenSpan f) -- (>>)
+ [ e -- e
+ , genPopSrcSpanExpr expand_stmts ])) -- stmts'
expand_do_stmts do_or_lc
((L _ (RecStmt { recS_stmts = rec_stmts
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -694,7 +694,7 @@ tcRnHsBootDecls boot_or_sig decls
, hs_defds = def_decls
, hs_ruleds = rule_decls
, hs_annds = _
- , hs_valds = (XValBindsLR (NValBinds val_binds val_sigs) :: HsValBinds GhcRn ) })
+ , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) })
<- rnTopSrcDecls first_group
-- The empty list is for extra dependencies coming from .hs-boot files
@@ -1620,7 +1620,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- and import the supporting declarations
traceTc "Tc3" empty ;
(tcg_env, inst_infos, th_bndrs,
- (XValBindsLR (NValBinds deriv_binds deriv_sigs) :: HsValBinds GhcRn))
+ XValBindsLR (NValBinds deriv_binds deriv_sigs))
<- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
updLclEnv (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a3e438d44110d27740647f1a6b56c1b64227508
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a3e438d44110d27740647f1a6b56c1b64227508
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/20230524/f1b5a2a6/attachment-0001.html>
More information about the ghc-commits
mailing list