[Git][ghc/ghc][wip/expand-do] more MR review changes
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Sat Oct 14 22:02:28 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
69cff342 by Apoorv Ingle at 2023-10-14T17:02:08-05:00
more MR review changes
- - - - -
13 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.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/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Zonk/Type.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -466,14 +466,9 @@ isHsThingRnStmt _ = False
isHsThingRnPat (OrigPat{}) = True
isHsThingRnPat _ = False
-type HsExpansionRn p
- = HsExpansion -- See Note [Expanding HsDo with HsExpansion] in `GHC.Tc.Gen.Do`
- HsThingRn -- Original source
- (HsExpr p) -- Expanded expression in a p pass
-
data XXExprGhcRn
- = ExpandedThingRn
- {-# UNPACK #-} !(HsExpansionRn GhcRn)
+ = ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing
+ , xrn_expanded :: HsExpr GhcRn } -- The compiler generated expanded thing
| PopErrCtxt -- A hint for typechecker to pop
{-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack
@@ -497,7 +492,7 @@ mkExpandedExpr
:: HsExpr GhcRn -- ^ source expression
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
-mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (HsExpanded (OrigExpr oExpr) eExpr))
+mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
@@ -506,13 +501,13 @@ mkExpandedStmt
:: ExprLStmt GhcRn -- ^ source statement
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
-mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (HsExpanded (OrigStmt oStmt) eExpr))
+mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr)
mkExpandedPatRn
:: LPat GhcRn -- ^ source pattern
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion'
-mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (HsExpanded (OrigPat oPat) eExpr))
+mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)
-- | Build an expression using the extension constructor `XExpr`,
-- and the two components of the expansion: original do stmt and
@@ -539,7 +534,8 @@ data XXExprGhcTc
| ExpandedThingTc -- See Note [Rebindable syntax and HsExpansion]
-- See Note [Expanding HsDo with HsExpansion] in `GHC.Tc.Gen.Do`
- {-# UNPACK #-} !(HsExpansionRn GhcTc)
+ { xtc_orig :: HsThingRn -- The original user written thing
+ , xtc_expanded :: HsExpr GhcTc } -- The expanded typechecked expression
| ConLikeTc -- Result of typechecking a data-con
-- See Note [Typechecking data constructors] in
@@ -567,7 +563,7 @@ mkExpandedExprTc
:: HsExpr GhcRn -- ^ source expression
-> HsExpr GhcTc -- ^ expanded typechecked expression
-> HsExpr GhcTc -- ^ suitably wrapped 'HsExpansion'
-mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (HsExpanded (OrigExpr oExpr) eExpr))
+mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr)
-- | Build a 'HsExpansion' out of an extension constructor.
-- The two components of the expansion are: original statement and
@@ -576,7 +572,7 @@ mkExpandedStmtTc
:: ExprLStmt GhcRn -- ^ source do statement
-> HsExpr GhcTc -- ^ expanded typechecked expression
-> HsExpr GhcTc -- ^ suitably wrapped 'HsExpansion'
-mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (HsExpanded (OrigStmt oStmt) eExpr))
+mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt) eExpr)
{- *********************************************************************
* *
@@ -822,18 +818,19 @@ instance Outputable HsThingRn where
where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
instance Outputable XXExprGhcRn where
- ppr (ExpandedThingRn e) = ppr e
- ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt<" <+> ppr e)) (ppr e)
+ ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)
+ ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
instance Outputable XXExprGhcTc where
ppr (WrapExpr (HsWrap co_fn e))
= pprHsWrapper co_fn (\_parens -> pprExpr e)
- ppr (ExpandedThingTc e)
- = ppr e -- e is an HsExpansion, we print the original
+ ppr (ExpandedThingTc o e)
+ = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)
+ -- e is the expanded expression, we print the original
-- expression (HsExpr GhcRn), not the
-- expanded typechecked one (HsExpr GhcTc),
- -- unless we are in ppr's debug mode then both get printed
+ -- unless we are in ppr's debug mode printed both
ppr (ConLikeTc con _ _) = pprPrefixOcc con
-- Used in error messages generated by
@@ -862,19 +859,19 @@ ppr_infix_expr (XExpr x) = case ghcPass @p of
ppr_infix_expr _ = Nothing
ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
-ppr_infix_expr_rn (ExpandedThingRn thing) = ppr_infix_hs_expansion thing
+ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
ppr_infix_expr_rn (PopErrCtxt (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 (ExpandedThingTc thing) = ppr_infix_hs_expansion thing
-ppr_infix_expr_tc (ConLikeTc {}) = Nothing
-ppr_infix_expr_tc (HsTick {}) = Nothing
-ppr_infix_expr_tc (HsBinTick {}) = Nothing
+ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e
+ppr_infix_expr_tc (ExpandedThingTc thing _) = ppr_infix_hs_expansion thing
+ppr_infix_expr_tc (ConLikeTc {}) = Nothing
+ppr_infix_expr_tc (HsTick {}) = Nothing
+ppr_infix_expr_tc (HsBinTick {}) = Nothing
-ppr_infix_hs_expansion :: HsExpansion HsThingRn b -> Maybe SDoc
-ppr_infix_hs_expansion thing | OrigExpr e <- original thing = ppr_infix_expr e
- | otherwise = Nothing
+ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc
+ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e
+ppr_infix_hs_expansion _ = Nothing
ppr_apps :: (OutputableBndrId p)
=> HsExpr (GhcPass p)
@@ -967,18 +964,18 @@ hsExprNeedsParens prec = go
go_x_tc :: XXExprGhcTc -> Bool
go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e
- go_x_tc (ExpandedThingTc thing) = hsExpandedNeedsParens thing
+ go_x_tc (ExpandedThingTc thing _) = hsExpandedNeedsParens thing
go_x_tc (ConLikeTc {}) = False
go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing) = hsExpandedNeedsParens thing
- go_x_rn (PopErrCtxt (L _ a)) = hsExprNeedsParens prec a
+ go_x_rn (ExpandedThingRn thing _) = hsExpandedNeedsParens thing
+ go_x_rn (PopErrCtxt (L _ a)) = hsExprNeedsParens prec a
- hsExpandedNeedsParens :: HsExpansion HsThingRn a -> Bool
- hsExpandedNeedsParens thing | OrigExpr e <- original thing = hsExprNeedsParens prec e
- | otherwise = False
+ hsExpandedNeedsParens :: HsThingRn -> Bool
+ hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e
+ hsExpandedNeedsParens _ = False
-- | Parenthesize an expression without token information
gHsPar :: LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
@@ -1014,18 +1011,18 @@ isAtomicHsExpr (XExpr x)
where
go_x_tc :: XXExprGhcTc -> Bool
go_x_tc (WrapExpr (HsWrap _ e)) = isAtomicHsExpr e
- go_x_tc (ExpandedThingTc thing) = isAtomicHsExpanded thing
+ go_x_tc (ExpandedThingTc thing _) = isAtomicHsExpanded thing
go_x_tc (ConLikeTc {}) = True
go_x_tc (HsTick {}) = False
go_x_tc (HsBinTick {}) = False
go_x_rn :: XXExprGhcRn -> Bool
- go_x_rn (ExpandedThingRn thing) = isAtomicHsExpanded thing
- go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a
+ go_x_rn (ExpandedThingRn thing _) = isAtomicHsExpanded thing
+ go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a
- isAtomicHsExpanded :: HsExpansion HsThingRn b -> Bool
- isAtomicHsExpanded thing | OrigExpr e <- original thing = isAtomicHsExpr e
- | otherwise = False
+ isAtomicHsExpanded :: HsThingRn -> Bool
+ isAtomicHsExpanded (OrigExpr e) = isAtomicHsExpr e
+ isAtomicHsExpanded _ = False
isAtomicHsExpr _ = False
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -144,7 +144,7 @@ hsExprType (HsStatic (_, ty) _s) = ty
hsExprType (HsPragE _ _ e) = lhsExprType e
hsExprType (HsEmbTy x _ _) = dataConCantHappen x
hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e
-hsExprType (XExpr (ExpandedThingTc thing)) = hsExprType $ expanded thing
+hsExprType (XExpr (ExpandedThingTc _ e)) = hsExprType e
hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
hsExprType (XExpr (HsTick _ e)) = lhsExprType e
hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -287,10 +287,10 @@ dsExpr (HsOverLit _ lit)
dsExpr e@(XExpr ext_expr_tc)
= case ext_expr_tc of
- ExpandedThingTc thing
- | OrigStmt (L loc _) <- original thing
- -> putSrcSpanDsA loc $ dsExpr (expanded thing)
- | otherwise -> dsExpr $ expanded thing
+ ExpandedThingTc o e
+ | OrigStmt (L loc _) <- o
+ -> putSrcSpanDsA loc $ dsExpr e
+ | otherwise -> dsExpr e
WrapExpr {} -> dsHsWrapped e
ConLikeTc con tvs tys -> dsConLike con tvs tys
-- Hpc Support
@@ -937,7 +937,7 @@ warnUnusedBindValue fun arg@(L loc _) arg_ty
fish_var (L _ (HsAppType _ e _ _)) = fish_var e
fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e)
return (l, e')
- fish_var (L l (XExpr (ExpandedThingTc thing))) = fish_var (L l (expanded thing))
+ fish_var (L l (XExpr (ExpandedThingTc _ e))) = fish_var (L l e)
fish_var _ = Nothing
warnUnusedBindValue _ _ _ = return ()
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -1168,10 +1168,10 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- we have to compare the wrappers
exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap h' e'))) =
wrap h h' && exp e e'
- exp (XExpr (ExpandedThingTc thing)) (XExpr (ExpandedThingTc thing'))
- | isHsThingRnExpr $ original thing
- , isHsThingRnExpr $ original thing'
- = exp (expanded thing) (expanded thing')
+ exp (XExpr (ExpandedThingTc o x)) (XExpr (ExpandedThingTc o' x'))
+ | isHsThingRnExpr o
+ , isHsThingRnExpr o'
+ = exp x x'
exp (HsVar _ i) (HsVar _ i') = i == i'
exp (XExpr (ConLikeTc c _ _)) (XExpr (ConLikeTc c' _ _)) = c == c'
-- the instance for IPName derives using the id, so this works if the
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1668,11 +1668,11 @@ repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel .
repE (HsEmbTy _ _ t) = do
t1 <- repLTy (hswc_body t)
rep2 typeEName [unC t1]
-repE e@(XExpr (ExpandedThingRn thing))
- | OrigExpr e <- original thing
+repE e@(XExpr (ExpandedThingRn o x))
+ | OrigExpr e <- o
= do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
; if rebindable_on -- See Note [Quotation and rebindable syntax]
- then repE $ expanded thing
+ then repE x
else repE e }
| otherwise
= notHandled (ThExpressionForm e)
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -446,13 +446,13 @@ isCallSite :: HsExpr GhcTc -> Bool
isCallSite HsApp{} = True
isCallSite HsAppType{} = True
isCallSite HsCase{} = True
-isCallSite (XExpr (ExpandedThingTc thing))
- | OrigStmt (L _ BodyStmt{}) <- original thing
+isCallSite (XExpr (ExpandedThingTc thing e))
+ | OrigStmt (L _ BodyStmt{}) <- thing
= False
- | OrigStmt (L _ LastStmt{}) <- original thing
+ | OrigStmt (L _ LastStmt{}) <- thing
= True
| otherwise
- = isCallSite $ expanded thing
+ = isCallSite e
-- NB: OpApp, SectionL, SectionR are all expanded out
isCallSite _ = False
@@ -591,8 +591,8 @@ addTickHsExpr (HsProc x pat cmdtop) =
addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =
liftM (XExpr . WrapExpr . HsWrap w) $
(addTickHsExpr e) -- Explicitly no tick on inside
-addTickHsExpr (XExpr (ExpandedThingTc (HsExpanded o e))) =
- liftM (XExpr . ExpandedThingTc . HsExpanded o) $
+addTickHsExpr (XExpr (ExpandedThingTc o e)) =
+ liftM (XExpr . ExpandedThingTc o) $
addTickHsExpr e
addTickHsExpr e@(XExpr (ConLikeTc {})) = return e
@@ -658,8 +658,8 @@ addTickGRHSBody isOneOfMany isLambda isDoExp expr@(L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints
- | XExpr (ExpandedThingTc thing) <- e0
- , OrigStmt (L _ LastStmt{}) <- original thing -> addTickLHsExprRHS expr
+ | XExpr (ExpandedThingTc thing _) <- e0
+ , OrigStmt (L _ LastStmt{}) <- thing -> addTickLHsExprRHS expr
| isDoExp -> addTickLHsExprNever expr
TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr
TickAllFunctions | isLambda ->
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -743,10 +743,10 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
RecordCon con_expr _ _ -> computeType con_expr
ExprWithTySig _ e _ -> computeLType e
HsPragE _ _ e -> computeLType e
- XExpr (ExpandedThingTc thing)
- | OrigExpr (HsGetField{}) <- original thing -- for record-dot-syntax
- -> Just (hsExprType $ expanded thing)
- | otherwise -> computeType (expanded thing)
+ XExpr (ExpandedThingTc thing e)
+ | OrigExpr (HsGetField{}) <- thing -- for record-dot-syntax
+ -> Just (hsExprType e)
+ | otherwise -> computeType e
XExpr (HsTick _ e) -> computeLType e
XExpr (HsBinTick _ _ e) -> computeLType e
e -> Just (hsExprType e)
@@ -1300,8 +1300,8 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
WrapExpr (HsWrap w a)
-> [ toHie $ L mspan a
, toHie (L mspan w) ]
- ExpandedThingTc thing
- -> [ toHie (L mspan $ expanded thing) ]
+ ExpandedThingTc _ e
+ -> [ toHie (L mspan e) ]
ConLikeTc con _ _
-> [ toHie $ C Use $ L mspan $ conLikeName con ]
HsTick _ expr
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -87,6 +87,14 @@ import qualified Data.List.NonEmpty as NE
{- Note [Handling overloaded and rebindable constructs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Nomenclature
+-------------
+* Expansion (`HsExpr GhcRn -> HsExpr GhcRn`): expand between renaming and
+ typechecking, using the `HsExpansion` constructor of `HsExpr`.
+* Desugaring (`HsExpr GhcTc -> Core.Expr`): convert the typechecked `HsSyn` to Core. This is done in GHC.HsToCore
+
+
For overloaded constructs (overloaded literals, lists, strings), and
rebindable constructs (e.g. if-then-else), our general plan is this,
using overloaded labels #foo as an example:
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -17,7 +17,7 @@
-- | Expand @Do@ block statements into @(>>=)@, @(>>)@ and @let at s
-- After renaming but right ebefore type checking
-module GHC.Tc.Gen.Do where
+module GHC.Tc.Gen.Do (expandDoStmts) where
import GHC.Prelude
@@ -66,22 +66,29 @@ expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
-- See Note [Expanding HsDo with HsExpansion]
expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
-expand_do_stmts ListComp _ = pprPanic "expand_do_stmts: impossible happened. ListComp" empty
+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`
expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
+ -- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
expand_do_stmts _ (stmt@(L _ (ApplicativeStmt{})): _) =
pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt
+ -- Handeled by tcSyntaxOp see `GHC.Tc.Gen.Match.tcStmtsAndThen`
+
expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
- -- last statement of a list comprehension, needs to explicitly return it
- -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
+-- See Note [Expanding HsDo with HsExpansion] 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
= do traceTc "expand_do_stmts last" (ppr ret_expr)
@@ -97,6 +104,7 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
return $ mkExpandedStmtPopAt loc stmt expansion
expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bs)) : lstmts) =
+-- See Note [Expanding HsDo with HsExpansion] Equation (3) below
-- stmts ~~> stmts'
-- ------------------------------------------------
-- let x = e ; stmts ~~> let x = e in stmts'
@@ -107,8 +115,8 @@ expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bs)) : lstmts) =
expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
, fail_op <- xbsrn_failOp xbsrn
+-- See Note [Expanding HsDo with HsExpansion] Equation (2) below
-- the pattern binding pat can fail
--- instead of making a new internal name, the fail block is just an anonymous lambda
-- stmts ~~> stmt' f = \case pat -> stmts';
-- _ -> fail "Pattern match failure .."
-- -------------------------------------------------------
@@ -124,7 +132,8 @@ expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
--- See Note [BodyStmt]
+-- See Note [BodyStmt] in Language.Haskell.Syntax.Expr
+-- See Note [Expanding HsDo with HsExpansion] Equation (1) below
-- stmts ~~> stmts'
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
@@ -145,7 +154,8 @@ expand_do_stmts do_or_lc
-- at the end of expanded rec block
}))
: lstmts) =
--- See Note [Typing a RecStmt]
+-- See Note [Typing a RecStmt] in Language.Haskell.Syntax.Expr
+-- See Note [Expanding HsDo with HsExpansion] Equation (4) and (6) below
-- stmts ~~> stmts'
-- -------------------------------------------------------------------------------------------
-- rec { later_ids, local_ids, rec_block } ; stmts
@@ -227,20 +237,20 @@ mk_fail_block _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
{- Note [Expanding HsDo with HsExpansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We expand `do`-blocks before typechecking it, rather than type checking it and then
-desugaring it by re-using the existing `HsExpansions` and `RebindableSyntax` machinery.
+We expand `do`-blocks before typechecking it, by re-using the existing `HsExpansions` and `RebindableSyntax` machinery.
This is very similar to:
1. Expansions done in `GHC.Rename.Expr.rnHsIf` for expanding `HsIf`; and
2. `desugarRecordUpd` in `GHC.Tc.Gen.Expr.tcExpr` for expanding `RecordUpd`
+See Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
To disabmiguate desugaring (`HsExpr GhcTc -> Core.Expr`) we use the phrase expansion
(`HsExpr GhcRn -> HsExpr GhcRn`)
-See Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
-
This expansion is done right before typechecking and after renaming
See Part 2. of Note [Doing HsExpansion in the Renamer vs Typechecker] in `GHC.Rename.Expr`
+Historical note START
+---------------------
In previous versions of GHC, the `do`-notation wasn't expanded before typechecking,
instead the typechecker would operate directly on the original.
Why? because it ensured that type error messages were explained in terms of
@@ -262,8 +272,13 @@ what the programmer has written. In practice, however, this didn't work very wel
the quantifiers impredicatively (#18324). Again, that happens automatically if
you typecheck the expanded expression.
-* Equationally speaking, we have the following schema for expanding `do`-statements.
- They capture the essence of statement expansions as implemented in `expand_do_stmts`
+Historical note END
+-------------------
+
+Do Expansions Equationally
+--------------------------
+We have the following schema for expanding `do`-statements.
+They capture the essence of statement expansions as implemented in `expand_do_stmts`
DO【 _ 】 maps a sequence of do statements and recursively converts them into expressions
@@ -277,9 +292,21 @@ what the programmer has written. In practice, however, this didn't work very wel
_ -> fail "pattern p failure"))
(3) DO【 let x = e; ss 】
- = ‹ExpansionStmt (let x = e)› (let x = e in (‹PopErrCtxt›DO【 ss 】))
+ = ‹ExpansionStmt (let x = e)› (let x = e in (‹PopErrCtxt›DO【 ss 】))
+
+
+ (4) DO【 rec ss; sss 】
+ = (>>=) e (\vars -> ‹PopErrCtxt›DO【 sss 】))
+ where (vars, e) = RECDO【 ss 】
+
+ (5) DO【 s 】 = s
+
+ RECDO【 _ 】 maps a sequence of recursively dependent monadic statements and converts it into an expression paired
+ with the variables that the rec finds a fix point of.
+
+ (6) RECDO【 ss 】 = (vars, mfix (\~vars -> (>>=) (DO【 ss 】) (return vars)))
+ where vars are all the variables free in ss
- (4) DO【 s 】 = s
For a concrete example, consider a `do`-block written by the user
@@ -297,8 +324,7 @@ The {l1} etc are location/source span information stored in the AST by the parse
{g1} are compiler generated source spans.
-The 3 main points to consider are:
-
+The 3 non-obvious points to consider are:
1. Wrap the expression with a `fail` block if the pattern match is not irrefutable.
See Part 1. Below
2. Generate appropriate warnings for discarded results in a body statement
@@ -307,10 +333,12 @@ The 3 main points to consider are:
3. Generating appropriate type error messages which blame the correct source spans
See Part 3 Below
-Part 1. Wrapping failable patterns with fail blocks
----------------------------------------------------
+Part 1. Expanding Patterns Bindings
+-----------------------------------
If `p` is a failable pattern---checked by `GHC.Tc.Gen.Pat.isIrrefutableHsPatRnTcM`---
-we need to wrap it with a `fail`-block. For example, the expansion of the `do`-block
+we need to wrap it with a `fail`-block. See Equation (2) above.
+
+The expansion of the `do`-block
do { Just p <- e1; e2 }
@@ -321,7 +349,7 @@ we need to wrap it with a `fail`-block. For example, the expansion of the `do`-b
Just p -> e2
_ -> fail "failable pattern p at location")
-The `fail`-block wrapping is done in `GHC.Tc.Gen.Do.mk_failable_expr`.
+The `fail`-block wrapping is done by `GHC.Tc.Gen.Do.mk_failable_expr`.
* Note the explicit call to `fail`, in the monad of the `do`-block. Part of the specification
of do-notation is that if the pattern match fails, we fail in the monad, *not* just crash
@@ -331,20 +359,19 @@ The `fail`-block wrapping is done in `GHC.Tc.Gen.Do.mk_failable_expr`.
pattern is irrefuable, we don't want to generate that `fail` alternative, else we'll generate
a `MonadFail` constraint that isn't needed.
-* Why an anonymous continuation lambda?
- We need a lambda for the types to match: this expression is a second
- argument to `(>>=)` so it needs to be of type `a -> m b`, a function.
- It is anonymous because:
- a. the name will be compiler generated and will never be seen by the user, and;
- b. we are in the post renaming stage fresh naming will require non-trivial amount of plumbing for little gain.
+* _Wrinkle 1_: For pattern synonyms, we always wrap it with a `fail`-block.
+ When the pattern is irrefutable, we do not add the fail block.
+ This is important because the occurrence of `fail` means that the typechecker
+ will generate a `MonadFail` constraint, and the language spec says that
+ we should not do that for irrefutable patterns.
-* Wrinkle 1: For pattern synonyms, we always wrap it with a `fail`-block.
- The irrefutable pattern checker returns false for pattern synonyms, but then after desugaring
- we would get a pattern match checker's redundant pattern warnings. To avoid such
- spurious warnings we filter out those type patterns that appear in a do expansion generated match
- in `HsToCore.Match.matchWrapper`. (see testcase Typeable1.hs)
+ Note that pattern synonyms count as refutable (see `isIrrefutableHsPat`), and hence will generate
+ a `MonadFail` constraint, also, we would get a pattern match checker's redundant pattern warnings.
+ because after desugaring, it is marked as irrefutable! To avoid such
+ spurious warnings and type checker errors, we filter out those patterns that appear
+ in a do expansion generated match in `HsToCore.Match.matchWrapper`. (see testcase Typeable1.hs)
-* Wrinkle 2: The call to `fail` will give rise to a `MonadFail` constraint. What `CtOrigin` do we
+* _Wrinkle 2_: The call to `fail` will give rise to a `MonadFail` constraint. What `CtOrigin` do we
attach to that constraint? It should be a good one, because it'll show up in error
messages when the `MonadFail` constraint can't be solved. Ideally, it should identify the
pattern `p`. Hence, we wrap the `fail` alternative expression with a `ExpandedPat`
@@ -358,14 +385,15 @@ the value when `-Wunused-binds` flag is turned on. (See testcase T3263-2.hs)
For example the `do`-block
- do { e1; e2 }
+ do { e1; e2 } -- where, e1 :: m Int
expands to
(>>) e1 e2
-* If `e1` returns a non-() value then we emit a value discarded warning. This check is done during desugaring
- `HsToCore.dsExpr` in the `HsApp` with a call to `HsToCore.warnUnusedBindValue`.
+* If `e1` returns a non-() value we want to emit a warning, telling the user that they
+ are discarding the value returned by e1. This is done by `HsToCore.dsExpr` in the `HsApp`
+ with a call to `HsToCore.warnUnusedBindValue`.
* The decision to trigger the warning is: if the function is a compiler generated `(>>)`,
and its first argument `e1` has a non-() type
@@ -398,7 +426,7 @@ It stores the original statement (with location) and the expanded expression
This is similar to vanilla `HsExpansion` and rebindable syntax
See Note [Rebindable syntax and HsExpansion] in `GHC.Hs.Expr`.
- * Recall, that when a source function arugment fails to typecheck,
+ * Recall, that when a source function argument fails to typecheck,
we print an error message like "In the second argument of the function f..".
However, `(>>)` is generated thus, we don't want to display that to the user; it would be confusing.
But also, we do not want to completely ignore it as we do want to keep the error blame carets
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -658,9 +658,9 @@ tcXExpr (PopErrCtxt (L loc e)) res_ty
setSrcSpanA loc $
tcExpr e res_ty
-tcXExpr xe@(ExpandedThingRn thing) res_ty
- | OrigStmt ls@(L loc s at LetStmt{}) <- original thing
- , HsLet x tkLet binds tkIn e <- expanded thing
+tcXExpr xe@(ExpandedThingRn o e) res_ty
+ | OrigStmt ls@(L loc s at LetStmt{}) <- o
+ , HsLet x tkLet binds tkIn e <- e
= do { (binds', e') <- setSrcSpanA loc $
addStmtCtxt s $
tcLocalBinds binds $
@@ -668,15 +668,15 @@ tcXExpr xe@(ExpandedThingRn thing) res_ty
-- a duplicate error context
; return $ mkExpandedStmtTc ls (HsLet x tkLet binds' tkIn e')
}
- | OrigStmt ls@(L loc s at LastStmt{}) <- original thing
+ | OrigStmt ls@(L loc s at LastStmt{}) <- o
= setSrcSpanA loc $
addStmtCtxt s $
- mkExpandedStmtTc ls <$> tcExpr (expanded thing) res_ty
+ mkExpandedStmtTc ls <$> tcExpr e res_ty
-- It is important that we call tcExpr (and not tcApp) here as
-- `e` is just the last statement's body expression
-- and not a HsApp of a generated (>>) or (>>=)
-- This improves error messages e.g. T18324b.hs
- | OrigStmt ls@(L loc _) <- original thing
+ | OrigStmt ls@(L loc _) <- o
= setSrcSpanA loc $
mkExpandedStmtTc ls <$> tcApp (XExpr xe) res_ty
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -295,8 +295,8 @@ 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 (ExpandedThingRn thing))
- | OrigExpr fun <- original thing = VACall fun n noSrcSpan
+ top_ctxt n (XExpr (ExpandedThingRn o _))
+ | OrigExpr fun <- o = VACall fun n noSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
top_lctxt n (L _ fun) = top_ctxt n fun
@@ -324,28 +324,26 @@ splitHsApps e = go e (top_ctxt 0 e) []
HsQuasiQuote _ _ (L l _) -> set l ctxt -- l :: SrcAnn NoEpAnns
-- See Note [Looking through HsExpanded]
- go (XExpr (ExpandedThingRn thing)) ctxt args
- | let o = original thing
- , isHsThingRnExpr o
- = go (expanded thing) (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
+ go (XExpr (ExpandedThingRn o e)) ctxt args
+ | isHsThingRnExpr o
+ = go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
(EWrap (EExpand o) : args)
- | oStmt@(OrigStmt (L _ stmt)) <- original thing -- so that we set `(>>)` as generated
- , BodyStmt{} <- stmt -- and get the right unused bind warnings
- = go (expanded thing) (VAExpansion oStmt generatedSrcSpan generatedSrcSpan)
- -- See Part 3. in Note [Expanding HsDo with HsExpansion]
- (EWrap (EExpand oStmt) : args) -- in `GHC.Tc.Gen.Do`
+ | OrigStmt (L _ stmt) <- o -- so that we set `(>>)` as generated
+ , BodyStmt{} <- stmt -- and get the right unused bind warnings
+ = go e (VAExpansion o generatedSrcSpan generatedSrcSpan)
+ -- See Part 3. in Note [Expanding HsDo with HsExpansion]
+ (EWrap (EExpand o) : args) -- in `GHC.Tc.Gen.Do`
- | oPat@(OrigPat (L loc _)) <- original thing -- so that we set the compiler generated fail context
- = go (expanded thing) (VAExpansion oPat -- to be originating from a failable pattern
- (locA loc) (locA loc)) -- See Part 1. Wrinkle 2. of
- (EWrap (EExpand oPat) : args) -- Note [Expanding HsDo with HsExpansion]
+ | OrigPat (L loc _) <- o -- so that we set the compiler generated fail context
+ = go e (VAExpansion o (locA loc) (locA loc)) -- to be originating from a failable pattern
+ -- See Part 1. Wrinkle 2. of
+ (EWrap (EExpand o) : args) -- Note [Expanding HsDo with HsExpansion]
-- in `GHC.Tc.Gen.Do`
| otherwise
- , let o = original thing
- = go (expanded thing) (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
+ = go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
(EWrap (EExpand o) : args)
-- See Note [Desugar OpApp in the typechecker]
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -740,9 +740,9 @@ exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression"
-exprCtOrigin (XExpr (ExpandedThingRn thing)) | OrigExpr a <- original thing = exprCtOrigin a
- | OrigStmt _ <- original thing = DoOrigin
- | OrigPat p <- original thing = DoPatOrigin p
+exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOrigin a
+ | OrigStmt _ <- thing = DoOrigin
+ | OrigPat p <- thing = DoPatOrigin p
exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"
-- | Extract a suitable CtOrigin from a MatchGroup
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1066,9 +1066,10 @@ zonkExpr (XExpr (WrapExpr (HsWrap co_fn expr)))
do new_expr <- zonkExpr expr
return (XExpr (WrapExpr (HsWrap new_co_fn new_expr)))
-zonkExpr (XExpr (ExpandedThingTc thing))
- = XExpr . ExpandedThingTc <$> (do e' <- zonkExpr $ expanded thing
- return $ thing {expanded = e'})
+zonkExpr (XExpr (ExpandedThingTc thing e))
+ = do e' <- zonkExpr e
+ return $ XExpr (ExpandedThingTc thing e')
+
zonkExpr (XExpr (ConLikeTc con tvs tys))
= XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69cff3423209149765a9080b1c6f3d257fce99dd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69cff3423209149765a9080b1c6f3d257fce99dd
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/20231014/3e4ce880/attachment-0001.html>
More information about the ghc-commits
mailing list