summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorromes <rodrigo.m.mesquita@gmail.com>2022-03-16 22:51:14 +0000
committerromes <rodrigo.m.mesquita@gmail.com>2022-03-17 20:01:32 +0000
commit39512c476a9cf497506e30c342fd340cde0043af (patch)
tree644d46d9193b470e2e0e3a8ec088357352dacc7b
parent26cb5621207a4d82c4feb49a094c91762e7912fe (diff)
downloadhaskell-wip/shrink-ast-deps.tar.gz
TTG: TH brackets finishing toucheswip/shrink-ast-deps
Rewrite the critical notes and fix outdated ones, use `HsQuote GhcRn` (in `HsBracketTc`) for desugaring regardless of the bracket being typed or untyped, remove unused `EpAnn` from `Hs*Bracket GhcRn`, zonkExpr factor out common brackets code, ppr_expr factor out common brackets code, and fix tests, to finish MR https://gitlab.haskell.org/ghc/ghc/-/merge_requests/4782. ------------------------- Metric Decrease: hard_hole_fits -------------------------
-rw-r--r--compiler/GHC/Hs/Expr.hs185
-rw-r--r--compiler/GHC/Hs/Instances.hs2
-rw-r--r--compiler/GHC/HsToCore/Expr.hs4
-rw-r--r--compiler/GHC/HsToCore/Quote.hs37
-rw-r--r--compiler/GHC/HsToCore/Types.hs2
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs4
-rw-r--r--compiler/GHC/Rename/Splice.hs27
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs37
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs48
-rw-r--r--testsuite/tests/perf/compiler/hard_hole_fits.hs5
-rw-r--r--testsuite/tests/perf/compiler/hard_hole_fits.stderr72
-rw-r--r--testsuite/tests/th/T18102.stderr9
13 files changed, 186 insertions, 248 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 3b43377212..c14a23f794 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -200,87 +200,77 @@ have a (HsExpr GhcRn) for the quotation itself.
As such, when typechecking both typed and untyped brackets,
we keep a /renamed/ bracket in the extension field.
-Here is the life cycle of a /typed/ quote [|| e ||]:
-
- In this pass We need this information
- -------------------------------------------
- GhcPs The parsed expression :: HsExpr GhcPs
- GhcRn The renamed expression :: HsExpr GhcRn
- GhcTc Four things:
- - The renamed expression :: HsExpr GhcRn
- - [PendingTcSplice]
- - The type of the quote
- - Maybe QuoteWrapper
- - The typechecked expression :: HsExpr GhcTc
- - NB: At the moment, GHC doesn't /need/ the typechecked
- expression. Desugaring is done over the renamed expression.
-
-Here is the life cycle of an /untyped/ quote, which can be
-an expression [| e |], pattern [| p |], type [| t |] etc
-We combine these four into HsQuote = Expr + Pat + Type + Var
-
- In this pass We need this information
+The HsBracketTc, the GhcTc ext field for both brackets, contains:
+ - The renamed quote :: HsQuote GhcRn -- for the desugarer
+ - [PendingTcSplice]
+ - The type of the quote
+ - Maybe QuoteWrapper
+
+Note that (HsBracketTc) stores the untyped (HsQuote GhcRn) for both typed and
+untyped brackets. They are treated uniformly by the desugarer, and we can
+easily construct untyped brackets from typed ones (with ExpBr).
+
+Typed quotes
+~~~~~~~~~~~~
+Here is the life cycle of a /typed/ quote [|| e ||], whose datacon is
+ HsTypedBracket (XTypedBracket p) (LHsExpr p)
+
+ In pass p (XTypedBracket p) (LHsExpr p)
-------------------------------------------
- GhcPs The parsed quote :: HsQuote GhcPs
- GhcRn Two things:
- - The renamed quote :: HsQuote GhcRn
- - [PendingRnSplice]
- GhcTc Four things:
- - The renamed quote :: HsQuote GhcRn
- - [PendingTcSplice]
- - The type of the quote
- - Maybe QuoteWrapper
-
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When typechecking /typed/ brackets, we typecheck the /typed/ expression that's
-quoted, constructing an `HsTypedBracket GhcTc` with all the described above needed
-information in the `GhcTc` pass.
-
-When typechecking /untyped/ brackets, we cannot typecheck the /untyped/
-expression + pattern + type + etc that's quoted (called `HsQuote`), but,
-despite the /untyped quotation/, we **do** typecheck the "encompassing"
-`HsUntypedBracket` expression:
-
- Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`,
- even though `e` cannot be typechecked.
- (See Note [Typechecking Overloaded Quotes] in GHC.Tc.Gen.Splice)
-
-Since we cannot typecheck `HsQuote`, we shouldn't ever be able to construct
-`HsQuote GhcTc` (that's OK, because we also never need `HsQuote GhcTc`);
-However, `HsQuote GhcTc` is a field of `HsUntypedBracket GhcTc`, so making
-`HsQuote GhcTc` impossible to construct would make `HsUntypedBracket GhcTc`
-impossible to construct too, which is undesireable.
-
-Our solution to enforce at the type level that the `HsUntypedBracket GhcTc`
-field for `HsQuote GhcTc` doesn't exist is to make `HsQuote GhcTc` isomorphic to
-`NoExtField` by using TTG field extensions to make all constructors, except
-for `XQuote` (which takes `NoExtField`), unconstructable, with `DataConCantHappen`.
-
-As for `HsQuote`, this means `HsQuote GhcTc` is unconstructable except if it's
-to be a non-existent field in some constructor.
+ GhcPs Annotations only LHsExpr GhcPs
+ GhcRn Annotations only LHsExpr GhcRn
+ GhcTc HsBracketTc LHsExpr GhcTc: unused!
+
+Note that in the GhcTc tree, the second field (HsExpr GhcTc)
+is entirely unused; the desugarer uses the (HsExpr GhcRn) from the
+first field.
+
+Untyped quotes
+~~~~~~~~~~~~~~
+Here is the life cycle of an /untyped/ quote, whose datacon is
+ HsUntypedBracket (XUntypedBracket p) (HsQuote p)
+
+Here HsQuote is a sum-type of expressions [| e |], patterns [| p |],
+types [| t |] etc.
+
+ In pass p (XUntypedBracket p) (HsQuote p)
+ -------------------------------------------------------
+ GhcPs Annotations only HsQuote GhcPs
+ GhcRn Annotations, [PendingRnSplice] HsQuote GhcRn
+ GhcTc HsBracketTc HsQuote GhcTc: unused!
+
+The difficulty is: the typechecker does not typecheck the body of an
+untyped quote, so how do we make a (HsQuote GhcTc) to put in the
+second field?
+
+Answer: we use the extension constructor of HsQuote, XQuote, and make
+all the other constructors into DataConCantHappen. That is, the only
+non-bottom value of type (HsQuote GhcTc) is (XQuote noExtField). Hence
+the instances
+ type instance XExpBr GhcTc = DataConCantHappen
+ ...etc...
+
+See the related Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice
-}
-data HsBracketTc thing = HsBracketTc
- thing
- Type
- (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument
- -- to the quote.
- [PendingTcSplice] -- Output of the type checker is the *original*
- -- renamed expression, plus
- -- _typechecked_ splices to be
- -- pasted back in by the desugarer
+data HsBracketTc = HsBracketTc
+ { brack_renamed_quote :: (HsQuote GhcRn) -- See Note [The life cycle of a TH quotation]
+ , brack_ty :: Type
+ , brack_quote_wrapper :: (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument to the quote.
+ , brack_pending_splices :: [PendingTcSplice] -- Output of the type checker is the *original*
+ -- renamed expression, plus
+ -- _typechecked_ splices to be
+ -- pasted back in by the desugarer
+ }
type instance XTypedBracket GhcPs = EpAnn [AddEpAnn]
-type instance XTypedBracket GhcRn = EpAnn [AddEpAnn]
-type instance XTypedBracket GhcTc = HsBracketTc (LHsExpr GhcRn) -- See Note [The life cycle of a TH quotation]
+type instance XTypedBracket GhcRn = NoExtField
+type instance XTypedBracket GhcTc = HsBracketTc
type instance XUntypedBracket GhcPs = EpAnn [AddEpAnn]
-type instance XUntypedBracket GhcRn = (EpAnn [AddEpAnn], [PendingRnSplice])
- -- See Note [Pending Splices]
- -- Output of the renamer is the *original* renamed
- -- expression, plus
- -- _renamed_ splices to be type checked
-type instance XUntypedBracket GhcTc = HsBracketTc (HsQuote GhcRn) -- See Note [The life cycle of a TH quotation]
+type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices]
+ -- Output of the renamer is the *original* renamed expression,
+ -- plus _renamed_ splices to be type checked
+type instance XUntypedBracket GhcTc = HsBracketTc
-- ---------------------------------------------------------------------
@@ -725,23 +715,20 @@ ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
ppr_expr (HsSpliceE _ s) = pprSplice s
--- romes TODO: refactor common
ppr_expr (HsTypedBracket b e)
= case ghcPass @p of
GhcPs -> thTyBrackets (ppr e)
GhcRn -> thTyBrackets (ppr e)
- GhcTc -> case b of
- HsBracketTc _ _ty _wrap [] -> thTyBrackets (ppr e)
- HsBracketTc _ _ty _wrap ps -> thTyBrackets (ppr e) $$ text "pending(tc)" <+> pprIfTc @p (ppr ps)
-ppr_expr (HsUntypedBracket b e)
+ GhcTc | HsBracketTc _ _ty _wrap ps <- b ->
+ thTyBrackets (ppr e) `ppr_with_pending_tc_splices` ps
+ppr_expr (HsUntypedBracket b q)
= case ghcPass @p of
- GhcPs -> ppr e
+ GhcPs -> ppr q
GhcRn -> case b of
- (_, []) -> ppr e
- (_, ps) -> ppr e $$ text "pending(rn)" <+> ppr ps
- GhcTc -> case b of
- HsBracketTc rne _ty _wrap [] -> ppr rne
- HsBracketTc rne _ty _wrap ps -> ppr rne $$ text "pending(tc)" <+> pprIfTc @p (ppr ps)
+ [] -> ppr q
+ ps -> ppr q $$ text "pending(rn)" <+> ppr ps
+ GhcTc | HsBracketTc rnq _ty _wrap ps <- b ->
+ ppr rnq `ppr_with_pending_tc_splices` ps
ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
= hsep [text "proc", ppr pat, text "->", ppr cmd]
@@ -1745,22 +1732,22 @@ bracket code. So for example
[| f $(g x) |]
looks like
- HsUntypedBracket _ (HsApp (HsVar "f") (HsSpliceE _ (g x)))
+ HsUntypedBracket _ (HsApp (HsVar "f") (HsSpliceE _ (HsUntypedSplice sn (g x)))
which the renamer rewrites to
HsUntypedBracket
- (_, [PendingRnSplice UntypedExpSplice sn (g x)])
- (HsApp (HsVar f) (HsSpliceE sn (g x)))
+ [PendingRnSplice UntypedExpSplice sn (g x)]
+ (HsApp (HsVar f) (HsSpliceE _ (HsUntypedSplice sn (g x)))
* The 'sn' is the Name of the splice point, the SplicePointName
* The PendingRnExpSplice gives the splice that splice-point name maps to;
and the typechecker can now conveniently find these sub-expressions
-* The other copy of the splice, in the second argument of HsSpliceE
- in the renamed first arg of HsRnBracketOut
- is used only for pretty printing
+* Note that a nested splice, such as the `$(g x)` now appears twice:
+ - In the PendingRnSplice: this is the version that will later be typechecked
+ - In the HsSpliceE in the body of the bracket. This copy is used only for pretty printing.
There are four varieties of pending splices generated by the renamer,
distinguished by their UntypedSpliceFlavour
@@ -1791,13 +1778,6 @@ checker:
* Pending *typed* expression splices, (PendingTcSplice), e.g.,
[||1 + $$(f 2)||]
-
-It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the
-output of the renamer. However, when pretty printing the output of the renamer,
-e.g., in a type error message, we *do not* want to print out the pending
-splices. In contrast, when pretty printing the output of the type checker, we
-*do* want to print the pending splices. So splitting them up seems to make
-sense, although I hate to add another constructor to HsExpr.
-}
instance OutputableBndrId p
@@ -1899,7 +1879,8 @@ instance OutputableBndrId p
GhcPs -> dataConCantHappen b
GhcRn -> dataConCantHappen b
#endif
- GhcTc -> ppr () -- romes TODO: so what do we do when we want to pretty print an HsQuote GhcTc? probably some pprPanic right? that's unfortunate...
+ GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b)
+ -- See Note [The life cycle of a TH quotation]
thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
@@ -1914,6 +1895,10 @@ instance Outputable PendingRnSplice where
instance Outputable PendingTcSplice where
ppr (PendingTcSplice n e) = pprPendingSplice n e
+ppr_with_pending_tc_splices :: SDoc -> [PendingTcSplice] -> SDoc
+ppr_with_pending_tc_splices x [] = x
+ppr_with_pending_tc_splices x ps = x $$ text "pending(tc)" <+> ppr ps
+
{-
************************************************************************
* *
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index fef85d1c60..987e47f047 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -388,7 +388,7 @@ deriving instance Data (HsQuote GhcPs)
deriving instance Data (HsQuote GhcRn)
deriving instance Data (HsQuote GhcTc)
-deriving instance Data thing => Data (HsBracketTc thing)
+deriving instance Data HsBracketTc
-- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p)
deriving instance Data (ArithSeqInfo GhcPs)
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 1d471d6321..8820d68a86 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -748,8 +748,8 @@ Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
-- Template Haskell stuff
-- See Note [The life cycle of a TH quotation]
-dsExpr (HsTypedBracket (HsBracketTc x _ hs_wrapper ps) _) = dsTypedBracket hs_wrapper x ps
-dsExpr (HsUntypedBracket (HsBracketTc x _ hs_wrapper ps) _) = dsUntypedBracket hs_wrapper x ps
+dsExpr (HsTypedBracket (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps
+dsExpr (HsUntypedBracket (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps
dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
-- Arrow notation extension
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index bb84275cf8..3bef613e28 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -27,7 +27,7 @@
-- a Royal Pain (triggers other recompilation).
-----------------------------------------------------------------------------
-module GHC.HsToCore.Quote( dsTypedBracket, dsUntypedBracket ) where
+module GHC.HsToCore.Quote( dsBracket ) where
import GHC.Prelude
import GHC.Platform
@@ -157,40 +157,27 @@ getPlatform :: MetaM Platform
getPlatform = targetPlatform <$> getDynFlags
-----------------------------------------------------------------------------
-dsTypedBracket :: Maybe QuoteWrapper
- -> LHsExpr GhcRn -- See Note [The life cycle of a TH quotation]
- -> [PendingTcSplice]
- -> DsM CoreExpr
-dsTypedBracket wrap exp splices
- = runOverloaded $ do { MkC e1 <- repLE exp ; return e1 }
- where
- -- romes TODO: factoring this method out requires many imports for its explicit type, is it worth it?
- runOverloaded act = do
- -- In the overloaded case we have to get given a wrapper, it is just
- -- for variable quotations that there is no wrapper, because they
- -- have a simple type.
- mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)
- runReaderT (mapReaderT (dsExtendMetaEnv (new_bit splices)) act) mw
-
-dsUntypedBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr
- -> HsQuote GhcRn -- See Note [The life cycle of a TH quotation]
- -> [PendingTcSplice]
- -> DsM CoreExpr
+dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr
+ -> HsQuote GhcRn -- See Note [The life cycle of a TH quotation]
+ -> [PendingTcSplice]
+ -> DsM CoreExpr
-- See Note [Desugaring Brackets]
-- Returns a CoreExpr of type (M TH.Exp)
-- The quoted thing is parameterised over Name, even though it has
-- been type checked. We don't want all those type decorations!
-dsUntypedBracket wrap brack splices
+dsBracket wrap brack splices
= do_brack brack
where
- -- romes TODO: factoring this method out requires many imports for its explicit type, is it worth it?
runOverloaded act = do
-- In the overloaded case we have to get given a wrapper, it is just
-- for variable quotations that there is no wrapper, because they
-- have a simple type.
mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)
- runReaderT (mapReaderT (dsExtendMetaEnv (new_bit splices)) act) mw
+ runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw
+
+ new_bit = mkNameEnv [(n, DsSplice (unLoc e))
+ | PendingTcSplice n e <- splices]
do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM (unLoc n) ; return e1 }
do_brack (ExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 }
@@ -199,10 +186,6 @@ dsUntypedBracket wrap brack splices
do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
do_brack (DecBrL {}) = panic "dsUntypedBracket: unexpected DecBrL"
-new_bit :: [PendingTcSplice] -> NameEnv DsMetaVal
-new_bit splices = mkNameEnv [(n, DsSplice (unLoc e))
- | PendingTcSplice n e <- splices]
-
{-
Note [Desugaring Brackets]
diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs
index e147758260..59db2c9372 100644
--- a/compiler/GHC/HsToCore/Types.hs
+++ b/compiler/GHC/HsToCore/Types.hs
@@ -85,7 +85,7 @@ data DsMetaVal
-- The Id has type THSyntax.Var
| DsSplice (HsExpr GhcTc) -- These bindings are introduced by
- -- the PendingSplices on a HsBracketOut
+ -- the PendingSplices on a Hs*Bracket
-- | Desugaring monad. See also 'TcM'.
type DsM = TcRnIf DsGblEnv DsLclEnv
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 9ce99f3fdb..60885ae7ee 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1192,9 +1192,9 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
, toHie p
]
HsUntypedBracket xbracket b -> case hiePass @p of
- HieRn | (_, p) <- xbracket ->
+ HieRn ->
[ toHie b
- , toHie p
+ , toHie xbracket
]
HieTc | HsBracketTc _ _ _ p <- xbracket ->
[ toHie b
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index bf46b89cc9..e9eb2c78bb 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -73,16 +73,21 @@ import qualified GHC.LanguageExtensions as LangExt
************************************************************************
-}
-rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-rnTypedBracket e br_body
- = addErrCtxt (typedQuotationCtxtDoc br_body) $
- do { -- Check that -XTemplateHaskellQuotes is enabled and available
- thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes
+-- Check that -XTemplateHaskellQuotes is enabled and available
+checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM ()
+checkForTemplateHaskellQuotes e =
+ do { thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes
; unless thQuotesEnabled $
failWith ( TcRnUnknownMessage $ mkPlainError noHints $ vcat
[ text "Syntax error on" <+> ppr e
, text ("Perhaps you intended to use TemplateHaskell"
++ " or TemplateHaskellQuotes") ] )
+ }
+
+rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+rnTypedBracket e br_body
+ = addErrCtxt (typedQuotationCtxtDoc br_body) $
+ do { checkForTemplateHaskellQuotes e
-- Check for nested brackets
; cur_stage <- getStage
@@ -103,20 +108,14 @@ rnTypedBracket e br_body
; traceRn "Renaming typed TH bracket" empty
; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body
- ; return (HsTypedBracket noAnn body', fvs_e)
+ ; return (HsTypedBracket noExtField body', fvs_e)
}
rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnUntypedBracket e br_body
= addErrCtxt (untypedQuotationCtxtDoc br_body) $
- do { -- Check that -XTemplateHaskellQuotes is enabled and available
- thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes
- ; unless thQuotesEnabled $
- failWith ( TcRnUnknownMessage $ mkPlainError noHints $ vcat
- [ text "Syntax error on" <+> ppr e
- , text ("Perhaps you intended to use TemplateHaskell"
- ++ " or TemplateHaskellQuotes") ] )
+ do { checkForTemplateHaskellQuotes e
-- Check for nested brackets
; cur_stage <- getStage
@@ -142,7 +141,7 @@ rnUntypedBracket e br_body
setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
rn_utbracket cur_stage br_body
; pendings <- readMutVar ps_var
- ; return (HsUntypedBracket (noAnn, pendings) body', fvs_e)
+ ; return (HsUntypedBracket pendings body', fvs_e)
}
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 93bbdaafa6..5cfe527c70 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -862,7 +862,7 @@ tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))
tcExpr expr res_ty
tcExpr (HsSpliceE _ splice) res_ty = tcSpliceExpr splice res_ty
tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty
-tcExpr e@(HsUntypedBracket (_, ps) body) res_ty = tcUntypedBracket e body ps res_ty
+tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty
{-
************************************************************************
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 48464f5ca5..c42dd689fa 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -213,11 +213,11 @@ tcTypedBracket rn_expr expr res_ty
; ps' <- readMutVar ps_ref
; codeco <- tcLookupId unsafeCodeCoerceName
; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName
- ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") -- romes TODO: What is Shouldn'tHappenOrigin? Is this still accurate?
+ ; tcWrapResultO (Shouldn'tHappenOrigin "TH typed bracket expression")
rn_expr
(unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)
(nlHsTyApp codeco [rep, expr_ty]))
- (noLocA (HsTypedBracket (HsBracketTc expr bracket_ty (Just wrapper) ps') tc_expr))))
+ (noLocA (HsTypedBracket (HsBracketTc (ExpBr noExtField expr) bracket_ty (Just wrapper) ps') tc_expr))))
meta_ty res_ty }
-- See Note [Typechecking Overloaded Quotes]
@@ -244,6 +244,7 @@ tcUntypedBracket rn_expr brack ps res_ty
-- type
; tcWrapResultO BracketOrigin rn_expr
(HsUntypedBracket (HsBracketTc brack expected_type brack_info ps') (XQuote noExtField))
+ -- (XQuote noExtField): see Note [The life cycle of a TH quotation] in GHC.Hs.Expr
expected_type res_ty
}
@@ -362,44 +363,46 @@ Remember, there are two forms of bracket
and untyped [| e |]
The life cycle of a typed bracket:
- * Starts as HsBracket
+ * Starts as HsTypedBracket
* When renaming:
* Set the ThStage to (Brack s RnPendingTyped)
* Rename the body
- * Result is still a HsBracket
+ * Result is a HsTypedBracket
* When typechecking:
* Set the ThStage to (Brack s (TcPending ps_var lie_var))
- * Typecheck the body, and throw away the elaborated result
+ * Typecheck the body, and keep the elaborated result (despite never using it!)
* Nested splices (which must be typed) are typechecked, and
the results accumulated in ps_var; their constraints
accumulate in lie_var
- * Result is a HsTcBracketOut rn_brack pending_splices
- where rn_brack is the incoming renamed bracket
+ * Result is a HsTypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) tc_brack
+ where rn_brack is the untyped renamed exp quote constructed from the typed renamed expression :: HsQuote GhcRn
--- romes TODO update note
The life cycle of a un-typed bracket:
- * Starts as HsBracket
+ * Starts as HsUntypedBracket
* When renaming:
* Set the ThStage to (Brack s (RnPendingUntyped ps_var))
* Rename the body
* Nested splices (which must be untyped) are renamed, and the
results accumulated in ps_var
- * Result is still (HsRnBracketOut rn_body pending_splices)
+ * Result is a HsUntypedBracket pending_splices rn_body
- * When typechecking a HsRnBracketOut
+ * When typechecking:
* Typecheck the pending_splices individually
* Ignore the body of the bracket; just check that the context
expects a bracket of that type (e.g. a [p| pat |] bracket should
be in a context needing a (Q Pat)
- * Result is a HsTcBracketOut rn_brack pending_splices
- where rn_brack is the incoming renamed bracket
+ * Result is a HsUntypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) (XQuote noExtField)
+ where rn_brack is the incoming renamed bracket :: HsQuote GhcRn
+ and (XQuote noExtField) stands for the removal of the `HsQuote GhcTc` field (since `HsQuote GhcTc` isn't possible)
+See the related Note [The life cycle of a TH quotation]
In both cases, desugaring happens like this:
- * HsTcBracketOut is desugared by GHC.HsToCore.Quote.dsBracket. It
+ * Hs*Bracket is desugared by GHC.HsToCore.Quote.dsBracket using the renamed
+ expression held in `HsBracketTc` (`type instance X*Bracket GhcTc = HsBracketTc`). It
a) Extends the ds_meta environment with the PendingSplices
attached to the bracket
@@ -421,11 +424,11 @@ In both cases, desugaring happens like this:
Example:
Source: f = [| Just $(g 3) |]
- The [| |] part is a HsBracket
+ The [| |] part is a HsUntypedBracket GhcPs
Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
- The [| |] part is a HsBracketOut, containing *renamed*
- (not typechecked) expression
+ The [| |] part is a HsUntypedBracket GhcTc, containing *renamed*
+ (not typechecked) expression (see Note [The life cycle of a TH quotation])
The "s7" is the "splice point"; the (g Int 3) part
is a typechecked expression
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 45e6ec9a02..b0af88d813 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -778,34 +778,11 @@ zonkExpr env (HsAppType ty e t)
return (HsAppType new_ty new_e t)
-- NB: the type is an HsType; can't zonk that!
--- romes TODO: refactor common
-zonkExpr env (HsTypedBracket (HsBracketTc hsb_thing ty wrap bs) body)
- = do wrap' <- traverse zonkQuoteWrap wrap
- bs' <- mapM (zonk_b env) bs
- new_ty <- zonkTcTypeToTypeX env ty
- return (HsTypedBracket (HsBracketTc hsb_thing new_ty wrap' bs') body)
- where
- zonkQuoteWrap (QuoteWrapper ev ty) = do
- let ev' = zonkIdOcc env ev
- ty' <- zonkTcTypeToTypeX env ty
- return (QuoteWrapper ev' ty')
-
- zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
- return (PendingTcSplice n e')
-
-zonkExpr env (HsUntypedBracket (HsBracketTc hsb_thing ty wrap bs) body)
- = do wrap' <- traverse zonkQuoteWrap wrap
- bs' <- mapM (zonk_b env) bs
- new_ty <- zonkTcTypeToTypeX env ty
- return (HsUntypedBracket (HsBracketTc hsb_thing new_ty wrap' bs') body)
- where
- zonkQuoteWrap (QuoteWrapper ev ty) = do
- let ev' = zonkIdOcc env ev
- ty' <- zonkTcTypeToTypeX env ty
- return (QuoteWrapper ev' ty')
+zonkExpr env (HsTypedBracket hsb_tc body)
+ = (\x -> HsTypedBracket x body) <$> zonkBracket env hsb_tc
- zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
- return (PendingTcSplice n e')
+zonkExpr env (HsUntypedBracket hsb_tc body)
+ = (\x -> HsUntypedBracket x body) <$> zonkBracket env hsb_tc
zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =
runTopSplice s >>= zonkExpr env
@@ -1102,6 +1079,22 @@ zonkOverLit env lit@(OverLit {ol_ext = x@OverLitTc { ol_witness = e, ol_type = t
, ol_type = ty' } }) }
-------------------------------------------------------------------------
+zonkBracket :: ZonkEnv -> HsBracketTc -> TcM HsBracketTc
+zonkBracket env (HsBracketTc hsb_thing ty wrap bs)
+ = do wrap' <- traverse zonkQuoteWrap wrap
+ bs' <- mapM (zonk_b env) bs
+ new_ty <- zonkTcTypeToTypeX env ty
+ return (HsBracketTc hsb_thing new_ty wrap' bs')
+ where
+ zonkQuoteWrap (QuoteWrapper ev ty) = do
+ let ev' = zonkIdOcc env ev
+ ty' <- zonkTcTypeToTypeX env ty
+ return (QuoteWrapper ev' ty')
+
+ zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
+ return (PendingTcSplice n e')
+
+-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc)
zonkArithSeq env (From e)
@@ -1124,7 +1117,6 @@ zonkArithSeq env (FromThenTo e1 e2 e3)
new_e3 <- zonkLExpr env e3
return (FromThenTo new_e1 new_e2 new_e3)
-
-------------------------------------------------------------------------
zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
=> ZonkEnv
diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.hs b/testsuite/tests/perf/compiler/hard_hole_fits.hs
index a1cbec4b59..c59fe1b0dd 100644
--- a/testsuite/tests/perf/compiler/hard_hole_fits.hs
+++ b/testsuite/tests/perf/compiler/hard_hole_fits.hs
@@ -38,9 +38,8 @@ testMe (RecordCon xrc gl hrf) = _
testMe (RecordUpd xru gl gls) = _
testMe (ExprWithTySig xewts gl hwcb) = _
testMe (ArithSeq xas m_se asi) = _
-testMe (HsBracket xb hb) = _
-testMe (HsRnBracketOut xrbo hb prss) = _
-testMe (HsTcBracketOut xtbo hb ptss as) = _
+testMe (HsTypedBracket xb hb) = _
+testMe (HsUntypedBracket xb hb) = _
testMe (HsSpliceE xse hs) = _
testMe (HsProc xp pat gl) = _
testMe (HsStatic xs gl) = _
diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.stderr b/testsuite/tests/perf/compiler/hard_hole_fits.stderr
index 78a3584f1c..4b59171506 100644
--- a/testsuite/tests/perf/compiler/hard_hole_fits.stderr
+++ b/testsuite/tests/perf/compiler/hard_hole_fits.stderr
@@ -539,13 +539,13 @@ hard_hole_fits.hs:40:34: warning: [-Wtyped-holes (in -Wdefault)]
(imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20
(and originally defined in ‘GHC.Enum’))
-hard_hole_fits.hs:41:28: warning: [-Wtyped-holes (in -Wdefault)]
+hard_hole_fits.hs:41:33: warning: [-Wtyped-holes (in -Wdefault)]
• Found hole: _ :: Int
- • In an equation for ‘testMe’: testMe (HsBracket xb hb) = _
+ • In an equation for ‘testMe’: testMe (HsTypedBracket xb hb) = _
• Relevant bindings include
- hb :: HsBracket GhcPs (bound at hard_hole_fits.hs:41:22)
- xb :: Language.Haskell.Syntax.Extension.XBracket GhcPs
- (bound at hard_hole_fits.hs:41:19)
+ hb :: LHsExpr GhcPs (bound at hard_hole_fits.hs:41:27)
+ xb :: Language.Haskell.Syntax.Extension.XTypedBracket GhcPs
+ (bound at hard_hole_fits.hs:41:24)
testMe :: HsExpr GhcPs -> Int (bound at hard_hole_fits.hs:14:1)
Valid hole fits include
maxBound :: forall a. Bounded a => a
@@ -557,16 +557,13 @@ hard_hole_fits.hs:41:28: warning: [-Wtyped-holes (in -Wdefault)]
(imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20
(and originally defined in ‘GHC.Enum’))
-hard_hole_fits.hs:42:40: warning: [-Wtyped-holes (in -Wdefault)]
+hard_hole_fits.hs:42:35: warning: [-Wtyped-holes (in -Wdefault)]
• Found hole: _ :: Int
- • In an equation for ‘testMe’:
- testMe (HsRnBracketOut xrbo hb prss) = _
+ • In an equation for ‘testMe’: testMe (HsUntypedBracket xb hb) = _
• Relevant bindings include
- prss :: [PendingRnSplice' GhcPs] (bound at hard_hole_fits.hs:42:32)
- hb :: HsBracket (HsBracketRn GhcPs)
- (bound at hard_hole_fits.hs:42:29)
- xrbo :: Language.Haskell.Syntax.Extension.XRnBracketOut GhcPs
- (bound at hard_hole_fits.hs:42:24)
+ hb :: HsQuote GhcPs (bound at hard_hole_fits.hs:42:29)
+ xb :: Language.Haskell.Syntax.Extension.XUntypedBracket GhcPs
+ (bound at hard_hole_fits.hs:42:26)
testMe :: HsExpr GhcPs -> Int (bound at hard_hole_fits.hs:14:1)
Valid hole fits include
maxBound :: forall a. Bounded a => a
@@ -578,36 +575,13 @@ hard_hole_fits.hs:42:40: warning: [-Wtyped-holes (in -Wdefault)]
(imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20
(and originally defined in ‘GHC.Enum’))
-hard_hole_fits.hs:43:43: warning: [-Wtyped-holes (in -Wdefault)]
- • Found hole: _ :: Int
- • In an equation for ‘testMe’:
- testMe (HsTcBracketOut xtbo hb ptss as) = _
- • Relevant bindings include
- as :: [PendingTcSplice' GhcPs] (bound at hard_hole_fits.hs:43:37)
- ptss :: HsBracket (HsBracketRn GhcPs)
- (bound at hard_hole_fits.hs:43:32)
- hb :: Maybe GHC.Tc.Types.Evidence.QuoteWrapper
- (bound at hard_hole_fits.hs:43:29)
- xtbo :: Language.Haskell.Syntax.Extension.XTcBracketOut GhcPs
- (bound at hard_hole_fits.hs:43:24)
- testMe :: HsExpr GhcPs -> Int (bound at hard_hole_fits.hs:14:1)
- Valid hole fits include
- maxBound :: forall a. Bounded a => a
- with maxBound @Int
- (imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20
- (and originally defined in ‘GHC.Enum’))
- minBound :: forall a. Bounded a => a
- with minBound @Int
- (imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20
- (and originally defined in ‘GHC.Enum’))
-
-hard_hole_fits.hs:44:29: warning: [-Wtyped-holes (in -Wdefault)]
+hard_hole_fits.hs:43:29: warning: [-Wtyped-holes (in -Wdefault)]
• Found hole: _ :: Int
• In an equation for ‘testMe’: testMe (HsSpliceE xse hs) = _
• Relevant bindings include
- hs :: HsSplice GhcPs (bound at hard_hole_fits.hs:44:23)
+ hs :: HsSplice GhcPs (bound at hard_hole_fits.hs:43:23)
xse :: Language.Haskell.Syntax.Extension.XSpliceE GhcPs
- (bound at hard_hole_fits.hs:44:19)
+ (bound at hard_hole_fits.hs:43:19)
testMe :: HsExpr GhcPs -> Int (bound at hard_hole_fits.hs:14:1)
Valid hole fits include
maxBound :: forall a. Bounded a => a
@@ -619,15 +593,15 @@ hard_hole_fits.hs:44:29: warning: [-Wtyped-holes (in -Wdefault)]
(imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20
(and originally defined in ‘GHC.Enum’))
-hard_hole_fits.hs:45:29: warning: [-Wtyped-holes (in -Wdefault)]
+hard_hole_fits.hs:44:29: warning: [-Wtyped-holes (in -Wdefault)]
• Found hole: _ :: Int
• In an equation for ‘testMe’: testMe (HsProc xp pat gl) = _
• Relevant bindings include
- gl :: LHsCmdTop GhcPs (bound at hard_hole_fits.hs:45:23)
+ gl :: LHsCmdTop GhcPs (bound at hard_hole_fits.hs:44:23)
pat :: Language.Haskell.Syntax.Pat.LPat GhcPs
- (bound at hard_hole_fits.hs:45:19)
+ (bound at hard_hole_fits.hs:44:19)
xp :: Language.Haskell.Syntax.Extension.XProc GhcPs
- (bound at hard_hole_fits.hs:45:16)
+ (bound at hard_hole_fits.hs:44:16)
testMe :: HsExpr GhcPs -> Int (bound at hard_hole_fits.hs:14:1)
Valid hole fits include
maxBound :: forall a. Bounded a => a
@@ -639,13 +613,13 @@ hard_hole_fits.hs:45:29: warning: [-Wtyped-holes (in -Wdefault)]
(imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20
(and originally defined in ‘GHC.Enum’))
-hard_hole_fits.hs:46:27: warning: [-Wtyped-holes (in -Wdefault)]
+hard_hole_fits.hs:45:27: warning: [-Wtyped-holes (in -Wdefault)]
• Found hole: _ :: Int
• In an equation for ‘testMe’: testMe (HsStatic xs gl) = _
• Relevant bindings include
- gl :: LHsExpr GhcPs (bound at hard_hole_fits.hs:46:21)
+ gl :: LHsExpr GhcPs (bound at hard_hole_fits.hs:45:21)
xs :: Language.Haskell.Syntax.Extension.XStatic GhcPs
- (bound at hard_hole_fits.hs:46:18)
+ (bound at hard_hole_fits.hs:45:18)
testMe :: HsExpr GhcPs -> Int (bound at hard_hole_fits.hs:14:1)
Valid hole fits include
maxBound :: forall a. Bounded a => a
@@ -657,16 +631,16 @@ hard_hole_fits.hs:46:27: warning: [-Wtyped-holes (in -Wdefault)]
(imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20
(and originally defined in ‘GHC.Enum’))
-hard_hole_fits.hs:47:1: warning: [-Woverlapping-patterns (in -Wdefault)]
+hard_hole_fits.hs:46:1: warning: [-Woverlapping-patterns (in -Wdefault)]
Pattern match is redundant
In an equation for ‘testMe’: testMe (XExpr xe) = ...
-hard_hole_fits.hs:47:21: warning: [-Wtyped-holes (in -Wdefault)]
+hard_hole_fits.hs:46:21: warning: [-Wtyped-holes (in -Wdefault)]
• Found hole: _ :: Int
• In an equation for ‘testMe’: testMe (XExpr xe) = _
• Relevant bindings include
xe :: Language.Haskell.Syntax.Extension.XXExpr GhcPs
- (bound at hard_hole_fits.hs:47:15)
+ (bound at hard_hole_fits.hs:46:15)
testMe :: HsExpr GhcPs -> Int (bound at hard_hole_fits.hs:14:1)
Valid hole fits include
maxBound :: forall a. Bounded a => a
diff --git a/testsuite/tests/th/T18102.stderr b/testsuite/tests/th/T18102.stderr
index d757c9735f..866e3e0777 100644
--- a/testsuite/tests/th/T18102.stderr
+++ b/testsuite/tests/th/T18102.stderr
@@ -1,14 +1,16 @@
T18102.hs:11:22: error:
• Not in scope: ‘ifThenElse’
- • In the Template Haskell quotation [|| if True then 10 else 15 ||]
+ • In the Template Haskell typed quotation
+ [|| if True then 10 else 15 ||]
In the typed splice:
$$(do _stuff <- [|| if True then 10 else 15 ||]
return [])
T18102.hs:11:35: error:
• Not in scope: ‘fromInteger’
- • In the Template Haskell quotation [|| if True then 10 else 15 ||]
+ • In the Template Haskell typed quotation
+ [|| if True then 10 else 15 ||]
In the typed splice:
$$(do _stuff <- [|| if True then 10 else 15 ||]
return [])
@@ -18,7 +20,8 @@ T18102.hs:11:35: error:
T18102.hs:11:43: error:
• Not in scope: ‘fromInteger’
- • In the Template Haskell quotation [|| if True then 10 else 15 ||]
+ • In the Template Haskell typed quotation
+ [|| if True then 10 else 15 ||]
In the typed splice:
$$(do _stuff <- [|| if True then 10 else 15 ||]
return [])