[Git][ghc/ghc][wip/expand-do] do not leak generated expressions in the error context, need to fix push and...
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Thu May 25 06:03:53 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
03969860 by Apoorv Ingle at 2023-05-25T01:03:42-05:00
do not leak generated expressions in the error context, need to fix push and pop error contexts for ExpandedStmts
- - - - -
6 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Quote.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
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -454,11 +454,11 @@ type instance XXExpr GhcTc = XXExprGhcTc
* *
********************************************************************* -}
-type HsExprOrStmt a = Either (HsExpr a) (ExprLStmt a)
-
data XXExprGhcRn
- = ExpansionExprRn
- {-# UNPACK #-} !(HsExpansion (HsExprOrStmt GhcRn) (HsExpr GhcRn))
+ = ExpandedExpr
+ {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcRn))
+ | ExpandedStmt
+ {-# UNPACK #-} !(HsExpansion (ExprLStmt GhcRn) (LHsExpr GhcRn))
| PopSrcSpan
{-# UNPACK #-} !(LHsExpr GhcRn)
-- Placeholder for identifying generated source locations in GhcRn phase
@@ -480,13 +480,13 @@ mkExpandedExpr
:: HsExpr GhcRn -- ^ source expression
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
-mkExpandedExpr a b = XExpr (ExpansionExprRn (HsExpanded (Left a) b))
+mkExpandedExpr a b = XExpr (ExpandedExpr (HsExpanded a b))
mkExpandedStmt
:: ExprLStmt GhcRn -- ^ source statement
- -> HsExpr GhcRn -- ^ expanded expression
+ -> LHsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
-mkExpandedStmt a b = XExpr (ExpansionExprRn (HsExpanded (Right a) b))
+mkExpandedStmt a b = XExpr (ExpandedStmt (HsExpanded a b))
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
@@ -752,11 +752,11 @@ ppr_expr (XExpr x) = case ghcPass @p of
GhcTc -> ppr x
instance Outputable XXExprGhcRn where
- 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 (ExpandedExpr ex@(HsExpanded o e)) = ifPprDebug (text "[ExpandedExpr]" <+> ppr ex)
+ (ppr (HsExpanded o e))
+ ppr (ExpandedStmt ex@(HsExpanded stmt e)) = ifPprDebug (text "[ExpandedStmt]" <+> ppr ex)
+ (ppr (HsExpanded stmt e))
+ ppr (PopSrcSpan e) = ifPprDebug (text "PopSrcSpan" <+> parens (ppr e))
(ppr e)
@@ -799,8 +799,8 @@ ppr_infix_expr (XExpr x) = case ghcPass @p of
ppr_infix_expr _ = Nothing
ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
-ppr_infix_expr_rn (ExpansionExprRn (HsExpanded (Left a) _)) = ppr_infix_expr a
-ppr_infix_expr_rn (ExpansionExprRn _) = Nothing
+ppr_infix_expr_rn (ExpandedExpr (HsExpanded a _)) = ppr_infix_expr a
+ppr_infix_expr_rn (ExpandedStmt _) = Nothing
ppr_infix_expr_rn (PopSrcSpan (L _ a)) = ppr_infix_expr a
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
@@ -911,8 +911,8 @@ hsExprNeedsParens prec = go
go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpansionExprRn (HsExpanded (Left a) _)) = hsExprNeedsParens prec a
- go_x_rn (ExpansionExprRn _) = False
+ go_x_rn (ExpandedExpr (HsExpanded a _)) = hsExprNeedsParens prec a
+ go_x_rn (ExpandedStmt _) = False
go_x_rn (PopSrcSpan (L _ a)) = hsExprNeedsParens prec a
@@ -956,8 +956,8 @@ isAtomicHsExpr (XExpr x)
go_x_tc (HsBinTick {}) = False
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpansionExprRn (HsExpanded (Left a) _)) = isAtomicHsExpr a
- go_x_rn (ExpansionExprRn (HsExpanded _ _)) = False
+ go_x_rn (ExpandedExpr (HsExpanded a _)) = isAtomicHsExpr a
+ go_x_rn (ExpandedStmt _) = False
go_x_rn (PopSrcSpan (L _ a)) = isAtomicHsExpr a
isAtomicHsExpr _ = False
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1654,14 +1654,13 @@ repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do
e1 <- repLE e
repGetField e1 f
repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs)
-repE (XExpr (ExpansionExprRn (HsExpanded orig_expr_or_stmt ds_expr)))
+repE (XExpr (ExpandedExpr (HsExpanded orig_expr ds_expr)))
= do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
; if rebindable_on -- See Note [Quotation and rebindable syntax]
then repE ds_expr
- else case orig_expr_or_stmt of
- Left e -> repE e
- Right st -> pprPanic "repE: unexpected do stmt" (ppr st)}
+ else repE orig_expr }
repE (XExpr (PopSrcSpan (L _ e))) = repE e
+repE e@(XExpr (ExpandedStmt _)) = notHandled (ThExpressionForm e)
repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -207,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 (Left _) _))) res_ty = tcApp e res_ty
+tcExpr e@(XExpr (ExpandedExpr {})) res_ty = tcApp e res_ty
tcExpr e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
@@ -409,9 +409,12 @@ 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 (XExpr (PopSrcSpan expr)) res_ty = popErrCtxt $ tcExpr (unLoc expr) res_ty
+
+tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
+ = do { traceTc "tcDoStmts stmt" (ppr expr)
+ ; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
+ tcExpr (unLoc expr) res_ty
}
tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
@@ -421,7 +424,7 @@ tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
; traceTc "tcDoStmts doExpr" (vcat [ text "original:" <+> ppr expanded_do_expr
, text "expanded:" <+> ppr expand_expr
])
- ; tcExpr expanded_do_expr res_ty
+ ; addErrCtxt (text "In the" <+> matchDoContextErrString doFlav) $ popErrCtxt $ tcExpr expanded_do_expr res_ty
}
tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) (L _ stmts)) res_ty
@@ -431,14 +434,12 @@ tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) (L _ stmts)) res_ty
; traceTc "tcDoStmts mDoExpr" (vcat [ text "original:" <+> ppr expanded_do_expr
, text "expanded:" <+> ppr expand_expr
])
- ; tcExpr expanded_do_expr res_ty
+ ; addErrCtxt (text "In the" <+> matchDoContextErrString doFlav) $ popErrCtxt $ tcExpr expanded_do_expr res_ty
}
tcExpr (HsDo _ do_or_lc stmts) res_ty
= tcDoStmts do_or_lc stmts res_ty
-tcExpr (XExpr (PopSrcSpan (L _ expr))) res_ty = popErrCtxt $ tcExpr expr 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') }
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -5,6 +5,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DisambiguateRecordFields #-}
@@ -292,7 +293,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
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 (ExpansionExprRn (HsExpanded (Left orig) _))) = VACall orig n noSrcSpan
+ top_ctxt n (XExpr (ExpandedExpr (HsExpanded orig _))) = VACall orig n noSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
top_lctxt n (L _ fun) = top_ctxt n fun
@@ -306,7 +307,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args)
-- See Note [Looking through HsExpanded]
- go (XExpr (ExpansionExprRn (HsExpanded (Left orig) fun))) ctxt args
+ go (XExpr (ExpandedExpr (HsExpanded orig fun))) ctxt args
= go fun (VAExpansion orig (appCtxtLoc ctxt))
(EWrap (EExpand orig) : args)
@@ -1464,6 +1465,8 @@ addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
+ XExpr (ExpandedStmt (HsExpanded stmt _)) ->
+ addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) thing_inside
_ -> addErrCtxt (exprCtxt e) thing_inside
-- The HsUnboundVar special case addresses situations like
-- f x = _
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1192,18 +1192,18 @@ 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 _ [stmt@(L _ (LastStmt _ body _ ret_expr))]
+expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
-- 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 (noLocA (mkExpandedStmt stmt (unLoc body)))
+ = return (noLocA (mkExpandedStmt stmt (genPopSrcSpanExpr body)))
| SyntaxExprRn ret <- ret_expr
--
-- ------------------------------------------------
-- return e ~~> return e
-- to make T18324 work
- = return $ noLocA (mkExpandedStmt stmt (genHsApp ret body))
+ = return $ genPopSrcSpanExpr (noLocA (mkExpandedStmt stmt (genPopSrcSpanExpr (L loc $ genHsApp ret body))))
expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
@@ -1218,19 +1218,22 @@ expand_do_stmts do_or_lc (stmt@(L _ (BindStmt xbsrn pat e)): lstmts)
do expand_stmts <- expand_do_stmts do_or_lc lstmts
expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
return $ noLocA (mkExpandedStmt stmt
- (unLoc $ mkHsApps (wrapGenSpan bind_op) -- (>>=)
- [ e
+ (mkHsApps (wrapGenSpan bind_op) -- (>>=)
+ [ genPopSrcSpanExpr e
, genPopSrcSpanExpr expr
]))
| otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
-expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
+expand_do_stmts do_or_lc (stmt@(L _ (LetStmt _ bnds)) : lstmts) =
-- stmts ~~> stmts'
-- ------------------------------------------------
-- let x = e ; stmts ~~> let x = e in stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ wrapGenSpan (HsLet noExtField noHsTok bnds noHsTok (genPopSrcSpanExpr expand_stmts))
+ return $ noLocA (mkExpandedStmt stmt
+ (wrapGenSpan (HsLet noExtField
+ noHsTok bnds
+ noHsTok (genPopSrcSpanExpr expand_stmts))))
expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
@@ -1240,8 +1243,8 @@ expand_do_stmts do_or_lc (stmt@(L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts)
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
return $ noLocA (mkExpandedStmt stmt
- (unLoc $ mkHsApps (wrapGenSpan f) -- (>>)
- [ e -- e
+ (mkHsApps (wrapGenSpan f) -- (>>)
+ [ genPopSrcSpanExpr e -- e
, genPopSrcSpanExpr expand_stmts ])) -- stmts'
expand_do_stmts do_or_lc
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -726,8 +726,8 @@ exprCtOrigin (HsTypedSplice {}) = Shouldn'tHappenOrigin "TH typed splice"
exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
-exprCtOrigin (XExpr (ExpansionExprRn (HsExpanded (Left a) _))) = exprCtOrigin a
-exprCtOrigin (XExpr (ExpansionExprRn _)) = DoOrigin
+exprCtOrigin (XExpr (ExpandedExpr (HsExpanded a _))) = exprCtOrigin a
+exprCtOrigin (XExpr (ExpandedStmt _)) = DoOrigin
exprCtOrigin (XExpr (PopSrcSpan (L _ a))) = exprCtOrigin a
-- | Extract a suitable CtOrigin from a MatchGroup
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/039698605384eac48bf2a97c50509121d4bdc0e5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/039698605384eac48bf2a97c50509121d4bdc0e5
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/20230525/edbac0fc/attachment-0001.html>
More information about the ghc-commits
mailing list