[Git][ghc/ghc][wip/expand-do] PopSrcSpan as a XXExprGhcRn
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon May 22 15:18:40 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
9c9e7235 by Apoorv Ingle at 2023-05-22T10:18:22-05:00
PopSrcSpan as a XXExprGhcRn
- - - - -
16 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Expr.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/Zonk.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -441,7 +441,7 @@ tupArgPresent (Missing {}) = False
********************************************************************* -}
type instance XXExpr GhcPs = DataConCantHappen
-type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn)
+type instance XXExpr GhcRn = XXExprGhcRn
type instance XXExpr GhcTc = XXExprGhcTc
-- HsExpansion: see Note [Rebindable syntax and HsExpansion] below
@@ -454,6 +454,19 @@ type instance XXExpr GhcTc = XXExprGhcTc
* *
********************************************************************* -}
+type HsExprOrStmt a = Either (HsExpr a) (ExprLStmt a)
+
+data XXExprGhcRn
+ = ExpansionExprRn !(HsExpansion (HsExprOrStmt GhcRn) (HsExpr GhcRn))
+ | PopSrcSpan !(LHsExpr GhcRn)
+ -- Placeholder for identifying generated source locations in GhcRn phase
+ -- Should not presist post typechecking
+ -- Note [Desugaring Do with HsExpansion] in GHC.Tc.Gen.Match
+
+
+mkPopSrcSpanExpr :: LHsExpr GhcRn -> HsExpr GhcRn
+mkPopSrcSpanExpr a = XExpr (PopSrcSpan a)
+
-- | Build a 'HsExpansion' out of an extension constructor,
-- and the two components of the expansion: original and
-- desugared expressions.
@@ -461,7 +474,7 @@ mkExpandedExpr
:: HsExpr GhcRn -- ^ source expression
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
-mkExpandedExpr a b = XExpr (HsExpanded a b)
+mkExpandedExpr a b = XExpr (ExpansionExprRn (HsExpanded (Left a) b))
data XXExprGhcTc
= WrapExpr -- Type and evidence application and abstractions
@@ -726,10 +739,9 @@ ppr_expr (XExpr x) = case ghcPass @p of
GhcRn -> ppr x
GhcTc -> ppr x
-ppr_expr (PopSrcSpan x) = case ghcPass @p of
- GhcPs -> panic "ppr_expr Ps HsPopSrcSpan"
- GhcRn -> ppr x
- GhcTc -> panic "ppr_expr Tc HsPopSrcSpan"
+instance Outputable XXExprGhcRn where
+ ppr (ExpansionExprRn e) = ppr e
+ ppr (PopSrcSpan e) = ppr e
instance Outputable XXExprGhcTc where
@@ -770,8 +782,10 @@ ppr_infix_expr (XExpr x) = case ghcPass @p of
GhcTc -> ppr_infix_expr_tc x
ppr_infix_expr _ = Nothing
-ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc
-ppr_infix_expr_rn (HsExpanded a _) = ppr_infix_expr a
+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 (PopSrcSpan (L _ a)) = ppr_infix_expr a
ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e
@@ -851,7 +865,6 @@ hsExprNeedsParens prec = go
go (HsDo _ sc _)
| isDoComprehensionContext sc = False
| otherwise = prec > topPrec
- go (PopSrcSpan{}) = prec > topPrec
go (ExplicitList{}) = False
go (RecordUpd{}) = False
go (ExprWithTySig{}) = prec >= sigPrec
@@ -881,8 +894,10 @@ hsExprNeedsParens prec = go
go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
- go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool
- go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a
+ go_x_rn :: XXExprGhcRn -> Bool
+ go_x_rn (ExpansionExprRn (HsExpanded (Left a) _)) = hsExprNeedsParens prec a
+ go_x_rn (ExpansionExprRn _) = False
+ go_x_rn (PopSrcSpan (L _ a)) = hsExprNeedsParens prec a
-- | Parenthesize an expression without token information
@@ -924,8 +939,10 @@ isAtomicHsExpr (XExpr x)
go_x_tc (HsTick {}) = False
go_x_tc (HsBinTick {}) = False
- go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool
- go_x_rn (HsExpanded a _) = isAtomicHsExpr a
+ go_x_rn :: XXExprGhcRn -> Bool
+ go_x_rn (ExpansionExprRn (HsExpanded (Left a) _)) = isAtomicHsExpr a
+ go_x_rn (ExpansionExprRn (HsExpanded _ _)) = False
+ go_x_rn (PopSrcSpan (L _ a)) = isAtomicHsExpr a
isAtomicHsExpr _ = False
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -556,6 +556,7 @@ deriving instance Eq (IE GhcTc)
-- ---------------------------------------------------------------------
+deriving instance Data XXExprGhcRn
deriving instance Data XXExprGhcTc
deriving instance Data XXPatGhcTc
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -120,7 +120,6 @@ hsExprType (HsIf _ _ t _) = lhsExprType t
hsExprType (HsMultiIf ty _) = ty
hsExprType (HsLet _ _ _ _ body) = lhsExprType body
hsExprType (HsDo ty _ _) = ty
-hsExprType (PopSrcSpan expr) = pprPanic "hsExprType" (text "impossible happened PopSrcSpan" <+> ppr expr)
hsExprType (ExplicitList ty _) = mkListTy ty
hsExprType (RecordCon con_expr _ _) = hsExprType con_expr
hsExprType (RecordUpd v _ _) = dataConCantHappen v
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -279,7 +279,7 @@ mkHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
=> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> LHsExpr (GhcPass p)
-mkHsLamDoExp pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
+mkHsLamDoExp pats body = mkHsPar (noLocA $ HsLam noExtField matches)
where
matches = mkMatchGroup (Generated DoExpansion)
(noLocA [mkSimpleMatch LambdaExpr pats' body])
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -259,8 +259,6 @@ dsExpr (HsOverLit _ lit)
= do { warnAboutOverflowedOverLit lit
; dsOverLit lit }
-dsExpr e@(PopSrcSpan {}) = pprPanic "dsExpr" (ppr e)
-
dsExpr e@(XExpr ext_expr_tc)
= case ext_expr_tc of
ExpansionExpr (HsExpanded _ b) -> dsExpr b
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1654,16 +1654,19 @@ 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 (HsExpanded orig_expr ds_expr))
+repE (XExpr (ExpansionExprRn (HsExpanded orig_expr_or_stmt ds_expr)))
= do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
; if rebindable_on -- See Note [Quotation and rebindable syntax]
then repE ds_expr
- else repE orig_expr }
+ else case orig_expr_or_stmt of
+ Left e -> repE e
+ Right st -> pprPanic "repE: unexpected do stmt" (ppr st)}
+repE (XExpr (PopSrcSpan (L _ e))) = repE e
repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsProc{}) = notHandled (ThExpressionForm e)
-repE e@(PopSrcSpan{}) = notHandled (ThExpressionForm e)
+
{- Note [Quotation and rebindable syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -605,7 +605,6 @@ addTickHsExpr (XExpr (HsTick t e)) =
liftM (XExpr . HsTick t) (addTickLHsExprNever e)
addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =
liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)
-addTickHsExpr e@(PopSrcSpan _) = pprPanic "addTickHsExpr: impossible happen PopSrcSpan" (ppr e)
addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1234,7 +1234,6 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
]
HsGetField {} -> []
HsProjection {} -> []
- PopSrcSpan {} -> []
XExpr x
| HieTc <- hiePass @p
-> case x of
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -561,8 +561,6 @@ rnExpr (ArithSeq _ _ seq)
else
return (ArithSeq noExtField Nothing new_seq, fvs) }
-rnExpr (PopSrcSpan _) = panic "impossible happened rnExpr PopSrcSpan"
-
{-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -206,7 +206,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 (HsExpanded {})) res_ty = tcApp e res_ty
+tcExpr e@(XExpr (ExpansionExprRn (HsExpanded {}))) res_ty = tcApp e res_ty
tcExpr e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
@@ -431,7 +431,7 @@ tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) (L _ stmts)) res_ty
tcExpr (HsDo _ do_or_lc stmts) res_ty
= tcDoStmts do_or_lc stmts res_ty
-tcExpr (PopSrcSpan (L _ expr)) res_ty = popErrCtxt $ tcExpr expr 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
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -290,9 +290,9 @@ splitHsApps e = go e (top_ctxt 0 e) []
-- See Note [AppCtxt]
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 (HsAppType _ fun _ _) = top_lctxt (n+1) fun
top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
- top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig n noSrcSpan
+ top_ctxt n (XExpr (ExpansionExprRn (HsExpanded (Left 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 +306,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 (HsExpanded orig fun)) ctxt args
+ go (XExpr (ExpansionExprRn (HsExpanded (Left orig) fun))) ctxt args
= go fun (VAExpansion orig (appCtxtLoc ctxt))
(EWrap (EExpand orig) : args)
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1233,7 +1233,7 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
expand_stmts <- expand_do_stmts do_or_lc lstmts
return $ mkHsApps (genLHsVar bindMName) -- (Prelude.>>=)
[ e
- , mkHsLamDoExp [pat] (noLocA $ PopSrcSpan expand_stmts) -- (\ x -> stmts')
+ , mkHsLamDoExp [pat] (noLocA $ mkPopSrcSpanExpr expand_stmts) -- (\ x -> stmts')
]
expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
@@ -1244,13 +1244,13 @@ expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
return $ wrapGenSpan (HsLet noExtField noHsTok bnds noHsTok (expand_stmts))
-expand_do_stmts do_or_lc ((L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
+expand_do_stmts do_or_lc ((L loc (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 $ noLocA (PopSrcSpan (mkHsApps (wrapGenSpan f) -- (>>)
+ return $ L loc (mkPopSrcSpanExpr (mkHsApps (wrapGenSpan f) -- (>>)
[ e -- e
, expand_stmts ])) -- stmts'
@@ -1276,7 +1276,7 @@ expand_do_stmts do_or_lc
return $ mkHsApps (genLHsVar bindMName) -- (Prelude.>>=)
[ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block))
, mkHsLamDoExp [ mkBigLHsVarPatTup all_ids ] -- (\ x ->
- (noLocA $ PopSrcSpan expand_stmts) -- stmts')
+ (noLocA $ mkPopSrcSpanExpr expand_stmts) -- stmts')
]
where
local_only_ids = local_ids \\ later_ids -- get unique local rec ids;
@@ -1368,7 +1368,7 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
; if b
-- don't decorate with fail statement if
-- the pattern is irrefutable
- then return $ mkHsLamDoExp [pat] (noLocA (PopSrcSpan lexpr))
+ then return $ mkHsLamDoExp [pat] (noLocA (mkPopSrcSpanExpr lexpr))
else mk_fail_lexpr pat lexpr fail_op
}
@@ -1379,7 +1379,7 @@ mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsEx
mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
return $ noLocA (HsLam noExtField $ mkMatchGroup (Generated DoExpansion) -- \
- (noLocA [ mkHsCaseAlt pat (noLocA $ PopSrcSpan lexpr) -- pat -> expr
+ (noLocA [ mkHsCaseAlt pat (noLocA $ mkPopSrcSpanExpr lexpr) -- pat -> expr
, mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern"
(noLocA $ genHsApp fail_op
(mk_fail_msg_expr dflags (DoExpr Nothing) pat))
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -724,8 +724,9 @@ 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 (HsExpanded a _)) = exprCtOrigin a
-exprCtOrigin (PopSrcSpan (L _ e)) = exprCtOrigin e
+exprCtOrigin (XExpr (ExpansionExprRn (HsExpanded (Left a) _))) = exprCtOrigin a
+exprCtOrigin (XExpr (ExpansionExprRn _)) = DoOrigin
+exprCtOrigin (XExpr (PopSrcSpan (L _ a))) = exprCtOrigin a
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -846,8 +846,6 @@ zonkExpr env (HsDo ty do_or_lc (L l stmts))
new_ty <- zonkTcTypeToTypeX env ty
return (HsDo new_ty do_or_lc (L l new_stmts))
-zonkExpr env (PopSrcSpan (L _ exp)) = zonkExpr env exp
-
zonkExpr env (ExplicitList ty exprs)
= do new_ty <- zonkTcTypeToTypeX env ty
new_exprs <- zonkLExprs env exprs
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -584,11 +584,6 @@ data HsExpr p
-- general idea, and Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
-- for an example of how we use it.
- | PopSrcSpan (LHsExpr p)
- -- Placeholder for identifying generated source locations in GhcRn phase
- -- Should not presist post typechecking
- -- Note [Desugaring Do with HsExpansion] in GHC.Tc.Gen.Match
-
-- ---------------------------------------------------------------------
data DotFieldOcc p
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2661,7 +2661,6 @@ instance ExactPrint (HsExpr GhcPs) where
getAnnotationEntry (HsProc an _ _) = fromAnn an
getAnnotationEntry (HsStatic an _) = fromAnn an
getAnnotationEntry (HsPragE{}) = NoEntryVal
- getAnnotationEntry (PopSrcSpan{}) = NoEntryVal
setAnnotationAnchor a@(HsVar{}) _ _s = a
setAnnotationAnchor (HsUnboundVar an a) anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a)
@@ -2700,7 +2699,6 @@ instance ExactPrint (HsExpr GhcPs) where
setAnnotationAnchor (HsProc an a b) anc cs = (HsProc (setAnchorEpa an anc cs) a b)
setAnnotationAnchor (HsStatic an a) anc cs = (HsStatic (setAnchorEpa an anc cs) a)
setAnnotationAnchor a@(HsPragE{}) _ _s = a
- setAnnotationAnchor a@(PopSrcSpan{}) _ _s = a
exact (HsVar x n) = do
n' <- markAnnotated n
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9c9e72353f82ff6db4f163f419957bf0e45dd543
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9c9e72353f82ff6db4f163f419957bf0e45dd543
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/20230522/1be47371/attachment-0001.html>
More information about the ghc-commits
mailing list