[Git][ghc/ghc][wip/expand-do] 2 commits: - make the ExpandedStmt generated expression location-less
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue Jul 11 17:10:19 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
929f0851 by Apoorv Ingle at 2023-07-10T18:38:16-05:00
- make the ExpandedStmt generated expression location-less
- Introduce ExpansionStmt for proper `hsSplitApps`
- Introduce `VAExpansionStmt` that is just like `VAExpansion` but for statements
- - - - -
5364bb8e by Apoorv Ingle at 2023-07-11T12:09:55-05:00
some cleanup needed
- - - - -
11 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Zonk/Type.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -458,7 +458,7 @@ data XXExprGhcRn
= ExpandedExpr
{-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcRn))
| ExpandedStmt
- {-# UNPACK #-} !(HsExpansion (ExprLStmt GhcRn) (LHsExpr GhcRn))
+ {-# UNPACK #-} !(HsExpansion (ExprLStmt GhcRn) (HsExpr GhcRn))
| PopSrcSpan
{-# UNPACK #-} !(LHsExpr GhcRn)
-- Placeholder for identifying generated source locations in GhcRn phase
@@ -480,7 +480,7 @@ mkExpandedExpr a b = XExpr (ExpandedExpr (HsExpanded a b))
mkExpandedStmt
:: ExprLStmt GhcRn -- ^ source statement
- -> LHsExpr GhcRn -- ^ expanded expression
+ -> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
mkExpandedStmt a b = XExpr (ExpandedStmt (HsExpanded a b))
@@ -491,6 +491,9 @@ data XXExprGhcTc
| ExpansionExpr -- See Note [Rebindable syntax and HsExpansion] below
{-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))
+ | ExpansionStmt -- See Note [Rebindable syntax and HsExpansion] below
+ {-# UNPACK #-} !(HsExpansion (ExprLStmt GhcRn) (HsExpr GhcTc))
+
| ConLikeTc -- Result of typechecking a data-con
-- See Note [Typechecking data constructors] in
-- GHC.Tc.Gen.Head
@@ -765,6 +768,11 @@ instance Outputable XXExprGhcTc where
-- expression (LHsExpr GhcPs), not the
-- desugared one (LHsExpr GhcTc).
+ ppr (ExpansionStmt stmt)
+ = ppr stmt -- e is an HsExpansion, we print the original
+ -- expression (LHsExpr GhcPs), not the
+ -- desugared one (LHsExpr GhcTc).
+
ppr (ConLikeTc con _ _) = pprPrefixOcc con
-- Used in error messages generated by
-- the pattern match overlap checker
@@ -802,6 +810,7 @@ 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
ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a
+ppr_infix_expr_tc (ExpansionStmt {}) = Nothing
ppr_infix_expr_tc (ConLikeTc {}) = Nothing
ppr_infix_expr_tc (HsTick {}) = Nothing
ppr_infix_expr_tc (HsBinTick {}) = Nothing
@@ -822,7 +831,6 @@ ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))
pp (Right arg)
= text "@" <> ppr arg
-
pprDebugParendExpr :: (OutputableBndrId p)
=> PprPrec -> LHsExpr (GhcPass p) -> SDoc
pprDebugParendExpr p expr
@@ -902,6 +910,7 @@ hsExprNeedsParens prec = go
go_x_tc :: XXExprGhcTc -> Bool
go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e
go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a
+ go_x_tc (ExpansionStmt{}) = False
go_x_tc (ConLikeTc {}) = False
go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
@@ -947,6 +956,7 @@ isAtomicHsExpr (XExpr x)
go_x_tc :: XXExprGhcTc -> Bool
go_x_tc (WrapExpr (HsWrap _ e)) = isAtomicHsExpr e
go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a
+ go_x_tc (ExpansionStmt {}) = False
go_x_tc (ConLikeTc {}) = True
go_x_tc (HsTick {}) = False
go_x_tc (HsBinTick {}) = False
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -144,6 +144,7 @@ hsExprType (HsStatic (_, ty) _s) = ty
hsExprType (HsPragE _ _ e) = lhsExprType e
hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e
hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e
+hsExprType (XExpr (ExpansionStmt (HsExpanded _ tc_e))) = hsExprType tc_e
hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
hsExprType (XExpr (HsTick _ e)) = lhsExprType e
hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -265,6 +265,7 @@ dsExpr (HsOverLit _ lit)
dsExpr e@(XExpr ext_expr_tc)
= case ext_expr_tc of
ExpansionExpr (HsExpanded _ b) -> dsExpr b
+ ExpansionStmt (HsExpanded (L loc _) b) -> putSrcSpanDsA loc $ dsExpr b
WrapExpr {} -> dsHsWrapped e
ConLikeTc con tvs tys -> dsConLike con tvs tys
-- Hpc Support
@@ -880,6 +881,7 @@ warnUnusedBindValue fun arg@(L loc _) arg_ty
fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e)
return (l, e')
fish_var (L l (XExpr (ExpansionExpr (HsExpanded _ e)))) = fish_var (L l e)
+ fish_var (L l (XExpr (ExpansionStmt (HsExpanded _ e)))) = fish_var (L l e)
fish_var _ = Nothing
warnUnusedBindValue _ _ _ = return ()
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -158,7 +158,7 @@ pmcMatches origin ctxt vars matches = {-# SCC "pmcMatches" #-} do
-- should be strict in @missing@ anyway!
!missing <- getLdiNablas
tracePm "pmcMatches {" $
- hang (vcat [ppr ctxt, ppr vars, text "Matches:"])
+ hang (vcat [ppr origin, ppr ctxt, ppr vars, text "Matches:"])
2
((ppr matches) $$ (text "missing:" <+> ppr missing))
case NE.nonEmpty matches of
@@ -176,7 +176,7 @@ pmcMatches origin ctxt vars matches = {-# SCC "pmcMatches" #-} do
result <- {-# SCC "checkMatchGroup" #-}
unCA (checkMatchGroup matches) missing
tracePm "}: " (ppr (cr_uncov result))
- when (not (isDoExpansionGenerated origin)) -- Generated code shouldn't give overlapping warnings
+ when (not (isDoExpansionGenerated origin)) -- Generated code shouldn't emit overlapping warnings
({-# SCC "formatReportWarnings" #-}
formatReportWarnings ReportMatchGroup ctxt vars result)
return (NE.toList (ldiMatchGroup (cr_ret result)))
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -594,6 +594,9 @@ addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =
addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) =
liftM (XExpr . ExpansionExpr . HsExpanded a) $
(addTickHsExpr b)
+addTickHsExpr (XExpr (ExpansionStmt (HsExpanded a b))) =
+ liftM (XExpr . ExpansionStmt . HsExpanded a) $
+ (addTickHsExpr b)
addTickHsExpr e@(XExpr (ConLikeTc {})) = return e
-- We used to do a freeVar on a pat-syn builder, but actually
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1242,6 +1242,8 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
, toHie (L mspan w) ]
ExpansionExpr (HsExpanded _ b)
-> [ toHie (L mspan b) ]
+ ExpansionStmt (HsExpanded _ b)
+ -> [ toHie (L mspan b) ]
ConLikeTc con _ _
-> [ toHie $ C Use $ L mspan $ conLikeName con ]
HsTick _ expr
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -138,7 +138,7 @@ tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType
-- False <=> don't instantiate -- return a sigma-type
tcInferSigma inst (L loc rn_expr)
| (fun@(rn_fun,_), rn_args) <- splitHsApps rn_expr
- = addExprCtxt rn_expr $
+ = addExprCtxt (text "tcInferSigma") rn_expr $
setSrcSpanA loc $
do { do_ql <- wantQuickLook rn_fun
; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
@@ -357,12 +357,13 @@ tcApp rn_expr exp_res_ty
; let perhaps_add_res_ty_ctxt thing_inside
| insideExpansion fun_ctxt
, VACall (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) _))) _ _ <- fun_ctxt
- = do traceTc "tcApp" (vcat [text "VACall stmt", ppr loc, ppr rn_fun, ppr fun_ctxt])
- setSrcSpanA loc $ addStmtCtxt stmt thing_inside
- | insideExpansion fun_ctxt
- , XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) _)) <- rn_fun
- = do traceTc "tcApp" (vcat [text "VAExpansion stmt", ppr loc, ppr rn_fun, ppr fun_ctxt])
- setSrcSpanA loc $ addStmtCtxt stmt thing_inside
+ = do traceTc "tcApp" (vcat [text "VACall stmt", ppr stmt, ppr loc, ppr rn_fun, ppr fun_ctxt])
+ setSrcSpanA loc $ -- addStmtCtxt (text "tcApp VACall stmt") stmt
+ thing_inside
+ | XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) _)) <- rn_fun
+ = do traceTc "tcApp" (vcat [text "VAExpansion stmt", ppr stmt, ppr loc, ppr rn_fun, ppr fun_ctxt])
+ setSrcSpanA loc $ -- addStmtCtxt (text "tcApp VAExpansion stmt") stmt
+ thing_inside
| insideExpansion fun_ctxt
= do traceTc "tcApp" (vcat [text "insideExpansion", ppr rn_fun, ppr fun_ctxt])
addHeadCtxt fun_ctxt thing_inside
@@ -556,12 +557,13 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
maybeSetCtxt (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) _))) thing_inside
= do traceTc "tcInstFun" (text "set stmt ctxt" <+> ppr stmt <+> ppr loc)
setSrcSpanA loc $
- addStmtCtxt stmt thing_inside
+ addStmtCtxt (text "tcInstFun") stmt thing_inside
maybeSetCtxt _ thing_inside = thing_inside
fun_orig = exprCtOrigin (case fun_ctxt of
VAExpansion e _ -> e
- VACall e _ _ -> e)
+ VACall e _ _ -> e
+ VAExpansionStmt stmt _ -> HsDo noExtField (DoExpr Nothing) (L noSrcSpanA [stmt]))
-- Count value args only when complaining about a function
-- applied to too many value args
@@ -725,42 +727,32 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
, text "arg_loc" <+> ppr arg_loc
, text "is src ctxt" <+> ppr in_src_ctxt
, text "is generated code" <+> ppr in_generated_code
- , text "is then/bind"
- <+> ppr (is_then_fun (appCtxtExpr ctxt))
- <+> ppr (is_bind_fun (appCtxtExpr ctxt)) ])
+ -- , text "is then/bind"
+ -- <+> ppr (is_then_fun (appCtxtExpr ctxt))
+ -- <+> ppr (is_bind_fun (appCtxtExpr ctxt))
+ ])
; case ctxt of
VACall fun arg_no _ | not in_generated_code && not (is_then_fun fun || is_bind_fun fun)
-> do traceTc "addArgCtxt 2a" empty
setSrcSpanA arg_loc $
addErrCtxt (funAppCtxt fun arg arg_no) $
thing_inside
- VACall fun arg_no _ | not in_generated_code && (is_then_fun fun || is_bind_fun fun)
- -> do traceTc "addArgCtxt 2b" empty -- Skip setting "In the expression..." if the arg_no is > 1
- -- We have already set the context "In the stmt"
- if arg_no == 1 -- this arg location needs to be added
- then setSrcSpanA arg_loc $
- addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
- thing_inside
- else thing_inside
+ VACall fun _ _ | not in_generated_code && is_then_fun fun
+ -> do traceTc "addArgCtxt 2b >>" empty -- Skip setting "In the expression..." if the arg_no is > 1
+ thing_inside
VACall (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) _))) _ _
-> do traceTc "addArgCtxt 2c" empty -- Set the context "In the stmt .."
setSrcSpanA loc $
- addStmtCtxt stmt $
+ addStmtCtxt (text "addArgCtxt 2c") stmt $
thing_inside
VAExpansion (HsDo _ _ _) _
-> do traceTc "addArgCtxt 2d" empty -- Set the context as the first statement of do block
- -- setSrcSpan loc $ -- skip adding "In the expression do ... "
- -- addExprCtxt e $
- thing_inside
- VAExpansion _ _
- -> do traceTc "addArgCtxt 2e" empty -- Skip setting "In the expression..."
- -- as the arg will be an generated expanded stmt
- -- setSrcSpan loc $
- -- addExprCtxt orig $
+ -- setSrcSpanA arg_loc $ -- skip adding "In the expression do ... "
+ -- addExprCtxt ((text "addArgCtxt 2d")) e $
thing_inside
_ -> do traceTc "addArgCtxt 3" empty
setSrcSpanA arg_loc $
- addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
+ addExprCtxt (text "addArgCtxt 3") arg $ -- Auto-suppressed if arg_loc is generated
thing_inside }
where
is_then_fun :: HsExpr GhcRn -> Bool
@@ -771,6 +763,9 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
is_bind_fun (HsVar _ (L _ f)) = f == bindMName
is_bind_fun _ = False
+ -- mk_body_stmt :: HsExpr GhcRn -> ExprLStmt GhcRn
+ -- mk_body_stmt e = L arg_loc (BodyStmt noExtField (L arg_loc e) NoSyntaxExprRn NoSyntaxExprRn)
+
{- *********************************************************************
* *
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -122,7 +122,7 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
tcPolyLExpr (L loc expr) res_ty
= setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
- addExprCtxt expr $ -- Note [Error contexts in generated code]
+ addExprCtxt (text "tcPolyLExpr") expr $ -- Note [Error contexts in generated code]
do { expr' <- tcPolyExpr expr res_ty
; return (L loc expr') }
@@ -148,7 +148,7 @@ 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]
+ addExprCtxt (text "tcMonoExpr") expr $ -- Note [Error contexts in generated code]
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
@@ -162,7 +162,7 @@ tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
-- Infer a *rho*-type. The return type is always instantiated.
tcInferRho (L loc expr)
= setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
- addExprCtxt expr $ -- Note [Error contexts in generated code]
+ addExprCtxt (text "tcInferRho") expr $ -- Note [Error contexts in generated code]
do { (expr', rho) <- tcInfer (tcExpr expr)
; return (L loc expr', rho) }
@@ -215,14 +215,15 @@ tcExpr (XExpr (PopSrcSpan (L _ e))) res_ty
= do traceTc "tcExpr" (text "PopSrcSpan")
popErrCtxt $ tcExpr e res_ty
-tcExpr (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) (L _ e)))) res_ty
+tcExpr (XExpr (ExpandedStmt (HsExpanded stmt@(L loc _) e))) res_ty
= do { traceTc "tcDoStmts" (vcat [ text "stmt:" <+> ppr stmt
, text "expr:" <+> ppr e
, text "res_ty:" <+> ppr res_ty
, text "loc" <+> ppr loc
])
; setSrcSpanA loc $
- addStmtCtxt stmt $ tcExpr e res_ty
+ addStmtCtxt (text "tcExpr") stmt $
+ tcExpr e res_ty
}
@@ -431,7 +432,7 @@ tcExpr (HsMultiIf _ alts) res_ty
; return (HsMultiIf res_ty alts') }
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
-tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) ss@(L _ stmts)) res_ty
+tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) ss@(L loc stmts)) res_ty
= do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
; if isApplicativeDo
then tcDoStmts doFlav ss res_ty
@@ -441,12 +442,13 @@ tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) ss@(L _ stmts)) res_ty
; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
, text "expr:" <+> ppr expanded_expr
])
- ; -- addExprCtxt hsDo $
- tcExpr expanded_do_expr res_ty
+ ; setSrcSpanA loc $
+ -- addExprCtxt (text "tcExpr") hsDo $
+ tcExpr expanded_do_expr res_ty
}
}
-tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) ss@(L _ stmts)) res_ty
+tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) ss@(L loc stmts)) res_ty
= do { isApplicativeDo <- xoptM LangExt.ApplicativeDo
; if isApplicativeDo
then tcDoStmts doFlav ss res_ty
@@ -456,8 +458,9 @@ tcExpr hsDo@(HsDo _ doFlav@(MDoExpr{}) ss@(L _ stmts)) res_ty
; traceTc "tcDoStmts " (vcat [ text "hsDo:" <+> ppr hsDo
, text "expr:" <+> ppr expanded_expr
])
- ; -- addExprCtxt hsDo $
- tcExpr expanded_do_expr res_ty
+ ; setSrcSpanA loc $
+ -- addExprCtxt (text "tcExpr") hsDo $
+ tcExpr expanded_do_expr res_ty
}
}
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -189,6 +189,7 @@ data HsExprArg (p :: TcPass)
data EWrap = EPar AppCtxt
| EExpand (HsExpr GhcRn)
+ | EExpandStmt (ExprLStmt GhcRn)
| EHsWrap HsWrapper
data EValArg (p :: TcPass) where -- See Note [EValArg]
@@ -208,6 +209,10 @@ data AppCtxt
(HsExpr GhcRn) -- Inside an expansion of this expression
SrcSpan -- The SrcSpan of the expression
-- noSrcSpan if outermost; see Note [AppCtxt]
+ | VAExpansionStmt
+ (ExprLStmt GhcRn) -- Inside an expansion of this do stmt
+ SrcSpan -- The SrcSpan of the expression
+ -- noSrcSpan if outermost; see Note [AppCtxt]
| VACall
(HsExpr GhcRn) Int -- In the third argument of function f
@@ -243,18 +248,22 @@ a second time.
appCtxtLoc :: AppCtxt -> SrcSpan
appCtxtLoc (VAExpansion _ l) = l
+appCtxtLoc (VAExpansionStmt _ l) = l
appCtxtLoc (VACall _ _ l) = l
-appCtxtExpr :: AppCtxt -> HsExpr GhcRn
-appCtxtExpr (VAExpansion e _) = e
-appCtxtExpr (VACall e _ _) = e
+appCtxtExpr :: AppCtxt -> Maybe (HsExpr GhcRn)
+appCtxtExpr (VAExpansion e _) = Just e
+appCtxtExpr (VACall e _ _) = Just e
+appCtxtExpr _ = Nothing
insideExpansion :: AppCtxt -> Bool
insideExpansion (VAExpansion {}) = True
+insideExpansion (VAExpansionStmt {}) = True
insideExpansion (VACall {}) = False
instance Outputable AppCtxt where
ppr (VAExpansion e l) = text "VAExpansion" <+> ppr e <+> ppr l
+ ppr (VAExpansionStmt stmt l) = text "VAExpansionStmt" <+> ppr stmt <+> ppr l
ppr (VACall f n l) = text "VACall" <+> int n <+> ppr f <+> ppr l
type family XPass p where
@@ -300,7 +309,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
top_ctxt n (HsAppType _ fun _ _) = top_lctxt (n+1) fun
top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
top_ctxt n (XExpr (ExpandedExpr (HsExpanded orig _))) = VACall orig n noSrcSpan
- top_ctxt n other_fun@(XExpr (ExpandedStmt _)) = VACall other_fun n generatedSrcSpan
+ -- top_ctxt n (XExpr (ExpandedStmt (HsExpanded stmt _))) = VACall other_fun n generatedSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
top_lctxt n (L _ fun) = top_ctxt n fun
@@ -313,11 +322,20 @@ splitHsApps e = go e (top_ctxt 0 e) []
go (HsAppType _ (L l fun) at ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt at ty : args)
go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args)
+ go (XExpr (ExpandedExpr (HsExpanded orig@(HsDo _ _ _) fun))) ctxt args
+ = go fun (VAExpansion orig (appCtxtLoc ctxt))
+ (EWrap (EExpand orig) : args)
+
+
-- See Note [Looking through HsExpanded]
go (XExpr (ExpandedExpr (HsExpanded orig fun))) ctxt args
= go fun (VAExpansion orig (appCtxtLoc ctxt))
(EWrap (EExpand orig) : args)
+ go (XExpr (ExpandedStmt (HsExpanded stmt fun))) _ args
+ = go fun (VAExpansionStmt stmt generatedSrcSpan)
+ (EWrap (EExpandStmt stmt) : args)
+
-- See Note [Desugar OpApp in the typechecker]
go e@(OpApp _ arg1 (L l op) arg2) _ args
= ( (op, VACall op 0 (locA l))
@@ -331,10 +349,12 @@ splitHsApps e = go e (top_ctxt 0 e) []
set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
set l (VACall f n _) = VACall f n (locA l)
set _ ctxt@(VAExpansion {}) = ctxt
+ set _ ctxt@(VAExpansionStmt {}) = ctxt
dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt
dec l (VACall f n _) = VACall f (n-1) (locA l)
dec _ ctxt@(VAExpansion {}) = ctxt
+ dec _ ctxt@(VAExpansionStmt {}) = ctxt
-- | Rebuild an application: takes a type-checked application head
-- expression together with arguments in the form of typechecked 'HsExprArg's
@@ -378,6 +398,8 @@ rebuild_hs_apps fun ctxt (arg : args)
-> rebuild_hs_apps (gHsPar lfun) ctxt' args
EWrap (EExpand orig)
-> rebuild_hs_apps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args
+ EWrap (EExpandStmt stmt)
+ -> rebuild_hs_apps (XExpr (ExpansionStmt (HsExpanded stmt fun))) ctxt args
EWrap (EHsWrap wrap)
-> rebuild_hs_apps (mkHsWrap wrap fun) ctxt args
where
@@ -674,7 +696,9 @@ countVisAndInvisValArgs (EValArg {} : args) = 1 + countVisAndInvisValArgs args
countVisAndInvisValArgs (EWrap wrap : args) =
case wrap of { EHsWrap hsWrap -> countHsWrapperInvisArgs hsWrap + countVisAndInvisValArgs args
; EPar {} -> countVisAndInvisValArgs args
- ; EExpand {} -> countVisAndInvisValArgs args }
+ ; EExpand {} -> countVisAndInvisValArgs args
+ ; EExpandStmt {} -> countVisAndInvisValArgs args
+ }
countVisAndInvisValArgs (EPrag {} : args) = countVisAndInvisValArgs args
countVisAndInvisValArgs (ETypeArg {}: args) = countVisAndInvisValArgs args
@@ -706,6 +730,7 @@ instance Outputable EWrap where
ppr (EPar _) = text "EPar"
ppr (EHsWrap w) = text "EHsWrap" <+> ppr w
ppr (EExpand orig) = text "EExpand" <+> ppr orig
+ ppr (EExpandStmt orig) = text "EExpandStmt" <+> ppr orig
instance OutputableBndrId (XPass p) => Outputable (EValArg p) where
ppr (ValArg e) = ppr e
@@ -793,6 +818,11 @@ tcInferAppHead_maybe fun args
_ -> return Nothing
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
+-- addHeadCtxt (VAExpansionStmt stmt@(L stmt_loc _) _) thing_inside =
+-- do setSrcSpanA stmt_loc $
+-- addStmtCtxt (text "addHeadCtxt") stmt
+-- thing_inside
+
addHeadCtxt fun_ctxt thing_inside
| not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
= do traceTc "addHeadCtxt not good" (ppr fun_ctxt)
@@ -801,7 +831,8 @@ addHeadCtxt fun_ctxt thing_inside
= setSrcSpan fun_loc $
do traceTc "addHeadCtxt okay" (ppr fun_ctxt)
case fun_ctxt of
- VAExpansion orig _ -> addExprCtxt orig thing_inside
+ VAExpansion orig _ -> addExprCtxt (text "addHeadCtxt") orig thing_inside
+ VAExpansionStmt {} -> thing_inside
VACall {} -> thing_inside
where
fun_loc = appCtxtLoc fun_ctxt
@@ -1472,20 +1503,32 @@ mis-match in the number of value arguments.
* *
********************************************************************* -}
-addStmtCtxt :: ExprLStmt GhcRn -> TcRn a -> TcRn a
-addStmtCtxt stmt thing_inside
- = addErrCtxt ({-text "tcDoStmts" <+> -}
- pprStmtInCtxt @'Renamed @'Renamed @'Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) thing_inside
+addStmtCtxt :: SDoc -> ExprLStmt GhcRn -> TcRn a -> TcRn a
+addStmtCtxt _ stmt thing_inside
+ = addErrCtxt ({- doc <+> -}
+ pprStmtInCtxt (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) thing_inside
+
+ where
+ pprStmtInCtxt :: HsStmtContext GhcRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
+ pprStmtInCtxt ctxt stmt
+ = hang (text "In" <+> maybeExpansionClause stmt <+> text "a stmt of" <+> pprAStmtContext ctxt <> colon)
+ 2 (pprStmt stmt)
+ maybeExpansionClause :: StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
+ maybeExpansionClause stmt | BindStmt{} <- stmt = text "the expansion of"
+ | otherwise = empty
+
+
-addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
-addExprCtxt e thing_inside
+addExprCtxt :: SDoc -> HsExpr GhcRn -> TcRn a -> TcRn a
+addExprCtxt doc e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
- _ -> addErrCtxt (exprCtxt e) thing_inside
+ XExpr (ExpandedStmt (HsExpanded stmt _)) -> addStmtCtxt doc stmt thing_inside
+ _ -> addErrCtxt (exprCtxt doc e) thing_inside
-- The HsUnboundVar special case addresses situations like
-- f x = _
-- when we don't want to say "In the expression: _",
-- because it is mentioned in the error message itself
-exprCtxt :: HsExpr GhcRn -> SDoc
-exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr))
+exprCtxt :: SDoc -> HsExpr GhcRn -> SDoc
+exprCtxt _ expr = hang ({-doc <+> -}text "In the expression:") 2 (ppr (stripParensHsExpr expr))
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1201,9 +1201,8 @@ genPopSrcSpanExpr = wrapGenSpan . mkPopSrcSpanExpr
expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
case expanded_expr of
- L _ (XExpr (PopSrcSpan (L loc e))) -> return $ L loc e
- _ -> return expanded_expr
-
+ L _ (XExpr (PopSrcSpan (L loc e))) -> return $ L loc e
+ _ -> return expanded_expr
-- | Expand the Do statments so that it works fine with Quicklook
-- See Note[Rebindable Do and Expanding Statements]
@@ -1223,19 +1222,19 @@ expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
expand_do_stmts _ (stmt@(L _ (ApplicativeStmt _ _ _)): _) =
pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt
-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 $ wrapGenSpan (mkExpandedStmt stmt body)
+ = return $ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt (unLoc body)))
| SyntaxExprRn ret <- ret_expr
--
-- ------------------------------------------------
-- return e ~~> return e
-- to make T18324 work
- = return $ wrapGenSpan (mkExpandedStmt stmt (genHsApp (wrapGenSpan ret) body))
+ = return $ wrapGenSpan (mkPopSrcSpanExpr $ wrapGenSpan (mkExpandedStmt stmt (genHsApp (wrapGenSpan ret) body)))
expand_do_stmts do_or_lc (stmt@(L _ (LetStmt _ bs)) : lstmts) =
@@ -1243,7 +1242,7 @@ expand_do_stmts do_or_lc (stmt@(L _ (LetStmt _ bs)) : lstmts) =
-- ------------------------------------------------
-- let x = e ; stmts ~~> let x = e in stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ wrapGenSpan (mkExpandedStmt stmt (genHsLet bs $ genPopSrcSpanExpr expand_stmts))
+ return $ wrapGenSpan (mkPopSrcSpanExpr $ wrapGenSpan (mkExpandedStmt stmt (genHsLet bs $ expand_stmts)))
expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
@@ -1257,13 +1256,12 @@ expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
do -- isRebindableOn <- xoptM LangExt.RebindableSyntax
-- let spanWrap = if isRebindableOn then noLocA else wrapGenSpan
expand_stmts <- expand_do_stmts do_or_lc lstmts
- expr@(L l _) <- mk_failable_lexpr_tcm pat expand_stmts fail_op
- traceTc "expand_do_stmts" (vcat [ text "loc ex stmts" <+> ppr l])
- return $ wrapGenSpan (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt (
- (wrapGenSpan bind_op)
- `genHsApp` e)) -- (>>=)
+ expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
+ return $ wrapGenSpan (mkPopSrcSpanExpr $ wrapGenSpan (wrapGenSpan (mkExpandedStmt stmt (
+ (wrapGenSpan bind_op) -- (>>=)
+ `genHsApp` e))
`genHsApp`
- expr)
+ expr))
| otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
@@ -1273,13 +1271,12 @@ expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) :
-- e ; stmts ~~> (>>) e stmts'
do -- isRebindableOn <- xoptM LangExt.RebindableSyntax
-- let spanWrap = if isRebindableOn then noLocA else wrapGenSpan
- expand_stmts@(L l _) <- expand_do_stmts do_or_lc lstmts
- traceTc "expand_do_stmts" (vcat [ text "loc ex stmts" <+> ppr l])
- return $ wrapGenSpan (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt (
+ expand_stmts <- expand_do_stmts do_or_lc lstmts
+ return $ wrapGenSpan (mkPopSrcSpanExpr $ L loc ((L loc (mkExpandedStmt stmt (
(wrapGenSpan then_op) -- (>>)
- `genHsApp` e))
+ `genHsApp` e)))
`genHsApp`
- expand_stmts) -- stmts'
+ expand_stmts)) -- stmts'
expand_do_stmts do_or_lc
((L do_loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -1361,7 +1358,7 @@ mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
return $ wrapGenSpan (HsLam noExtField $ mkMatchGroup (Generated DoExpansion) -- \
(wrapGenSpan [ genHsCaseAltDoExp pat lexpr -- pat -> expr
, genHsCaseAltDoExp (wrapGenSpan (WildPat noExtField)) -- _ -> fail "fail pattern"
- (genHsApp (wrapGenSpan fail_op) (mk_fail_msg_expr dflags pat))
+ $ wrapGenSpan (genHsApp (wrapGenSpan fail_op) (mk_fail_msg_expr dflags pat))
]))
where
mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
@@ -1373,8 +1370,8 @@ mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
mk_fail_lexpr _ _ _ = pprPanic "mk_fail_lexpr: impossible happened" empty
-genHsApp :: LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
-genHsApp fun arg = wrapGenSpan (HsApp noAnn fun arg)
+genHsApp :: LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
+genHsApp fun arg = HsApp noAnn fun arg
genHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
=> [LPat (GhcPass p)]
@@ -1409,8 +1406,8 @@ genSimpleMatch ctxt pats rhs
Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats
, m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn }
-genHsLet :: HsLocalBindsLR GhcRn GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
-genHsLet bindings body = wrapGenSpan $ HsLet noExtField noHsTok bindings noHsTok body
+genHsLet :: HsLocalBindsLR GhcRn GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
+genHsLet bindings body = HsLet noExtField noHsTok bindings noHsTok body
{- Note [Expanding HsDo with HsExpansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1072,6 +1072,9 @@ zonkExpr (XExpr (WrapExpr (HsWrap co_fn expr)))
zonkExpr (XExpr (ExpansionExpr (HsExpanded a b)))
= XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr b
+zonkExpr (XExpr (ExpansionStmt (HsExpanded a b)))
+ = XExpr . ExpansionStmt . HsExpanded a <$> zonkExpr b
+
zonkExpr (XExpr (ConLikeTc con tvs tys))
= XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys
where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d1c9f376f483c2c7253ddb12585c027c9670b122...5364bb8e262ea9b8808eff6b7381c9217e4a1bc4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d1c9f376f483c2c7253ddb12585c027c9670b122...5364bb8e262ea9b8808eff6b7381c9217e4a1bc4
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/20230711/d19e2336/attachment-0001.html>
More information about the ghc-commits
mailing list