summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Hs/Expr.hs141
-rw-r--r--compiler/GHC/Hs/Instances.hs15
-rw-r--r--compiler/GHC/Hs/Syn/Type.hs4
-rw-r--r--compiler/GHC/HsToCore/Expr.hs11
-rw-r--r--compiler/GHC/HsToCore/Quote.hs10
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs15
-rw-r--r--compiler/GHC/Parser.y2
-rw-r--r--compiler/GHC/Rename/Splice.hs14
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs38
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs-boot8
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs9
12 files changed, 136 insertions, 133 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 5dfff39437..545eee5209 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -187,7 +187,47 @@ type instance HsDoRn (GhcPass _) = GhcRn
-- ---------------------------------------------------------------------
-data HsBracketTc = HsBracketTc
+{-
+Note [The life cycle of a TH quotation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When desugaring a bracket (aka quotation), we want to produce Core
+code that, when run, will produce the TH syntax tree for the quotation.
+To that end, we want to desugar /renamed/ but not /typechecked/ code;
+the latter is cluttered with the typechecker's elaboration that should
+not appear in the TH syntax tree. So in (HsExpr GhcTc) tree, we must
+have a (HsExpr GhcRn) for the quotation itself.
+
+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
+
+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
+ -------------------------------------------
+ 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
+-}
+
+data HsBracketTc thing = HsBracketTc
+ thing
Type
(Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument
-- to the quote.
@@ -198,14 +238,14 @@ data HsBracketTc = HsBracketTc
type instance XTypedBracket GhcPs = EpAnn [AddEpAnn]
type instance XTypedBracket GhcRn = EpAnn [AddEpAnn]
-type instance XTypedBracket GhcTc = HsBracketTc
+type instance XTypedBracket GhcTc = HsBracketTc (LHsExpr GhcRn) -- See Note [The life cycle of a TH quotation]
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
+type instance XUntypedBracket GhcTc = HsBracketTc (HsQuote GhcRn) -- See Note [The life cycle of a TH quotation]
-- ---------------------------------------------------------------------
@@ -649,13 +689,15 @@ ppr_expr (ExprWithTySig _ expr sig)
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)
+ 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)
= case ghcPass @p of
GhcPs -> ppr e
@@ -663,8 +705,8 @@ ppr_expr (HsUntypedBracket b e)
(_, []) -> ppr e
(_, ps) -> ppr e $$ text "pending(rn)" <+> ppr ps
GhcTc -> case b of
- HsBracketTc _ty _wrap [] -> ppr e
- HsBracketTc _ty _wrap ps -> ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps)
+ HsBracketTc _ _ty _wrap [] -> ppr e
+ HsBracketTc _ _ty _wrap ps -> ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps)
ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
= hsep [text "proc", ppr pat, text "->", ppr cmd]
@@ -1776,75 +1818,38 @@ ppr_splice :: (OutputableBndrId p)
ppr_splice herald n e trail
= herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail
-{-
-Note [Type-checking untyped brackets]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we type-check an untyped bracket, the actual bracket (the second argument
-of the HsUntypedBracket constructor in HsExpr) is kept in the renaming pass.
-
-Given that
-
- HsExpr p = ...
- | HsUntypedBracket (XUntypedBracket p) (HsUntypedBracket p)
-
-When p = GhcPs we should have HsExpr GhcPs and HsUntypedBracket GhcPs
-When p = GhcRn we should have HsExpr GhcRn and HsUntypedBracket GhcRn
-However, when p = GhcTc we should have HsExpr GhcTc and HsUntypedBracket GhcRn
-To work around this, the HsUntypedBracket extension constructor (XUntypedBracket !(XXUntypedBracket p)),
-when p = GhcTc, is used to hold the needed HsUntypedBracket GhcRn
-
-Note that a typed bracket is just fine: you'll see in tcTypedBracket that
-_tc_expr is just thrown away. It will comfortably come to rest inside a TExpBr
-(of type HsBracket GhcTc).
--}
-
-type instance XTExpBr (GhcPass _) = NoExtField
-type instance XXTypedBracket GhcPs = DataConCantHappen
-type instance XXTypedBracket GhcRn = DataConCantHappen
-type instance XXTypedBracket GhcTc = HsTypedBracket GhcRn -- romes TODO: See Note [Desugaring typed brackets]
-
-type instance XExpBr (GhcPass _) = NoExtField
-type instance XPatBr (GhcPass _) = NoExtField
-type instance XDecBrL (GhcPass _) = NoExtField
-type instance XDecBrG (GhcPass _) = NoExtField
-type instance XTypBr (GhcPass _) = NoExtField
-type instance XVarBr (GhcPass _) = NoExtField
-type instance XXUntypedBracket GhcPs = DataConCantHappen
-type instance XXUntypedBracket GhcRn = DataConCantHappen
-type instance XXUntypedBracket GhcTc = HsUntypedBracket GhcRn -- See Note [Type-checking untyped brackets]
+type instance XExpBr (GhcPass _) = NoExtField
+type instance XPatBr (GhcPass _) = NoExtField
+type instance XDecBrL (GhcPass _) = NoExtField
+type instance XDecBrG (GhcPass _) = NoExtField
+type instance XTypBr (GhcPass _) = NoExtField
+type instance XVarBr (GhcPass _) = NoExtField
+type instance XXQuote GhcPs = DataConCantHappen
+type instance XXQuote GhcRn = DataConCantHappen
+type instance XXQuote GhcTc = HsQuote GhcRn -- See Note [The life cycle of a TH quotation]
instance OutputableBndrId p
- => Outputable (HsTypedBracket (GhcPass p)) where
- ppr (TExpBr _ e) = thTyBrackets (ppr e)
- ppr (XTypedBracket b) = case ghcPass @p of
-#if __GLASGOW_HASKELL__ <= 900
- GhcPs -> dataConCantHappen b
- GhcRn -> dataConCantHappen b
-#endif
- GhcTc | (TExpBr _ e) <- b -> thTyBrackets (ppr e)
-
-instance OutputableBndrId p
- => Outputable (HsUntypedBracket (GhcPass p)) where
- ppr = pprHsUntypedBracket
+ => Outputable (HsQuote (GhcPass p)) where
+ ppr = pprHsQuote
where
- pprHsUntypedBracket :: forall p. (OutputableBndrId p)
- => HsUntypedBracket (GhcPass p) -> SDoc
- pprHsUntypedBracket (ExpBr _ e) = thBrackets empty (ppr e)
- pprHsUntypedBracket (PatBr _ p) = thBrackets (char 'p') (ppr p)
- pprHsUntypedBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)
- pprHsUntypedBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))
- pprHsUntypedBracket (TypBr _ t) = thBrackets (char 't') (ppr t)
- pprHsUntypedBracket (VarBr _ True n)
+ pprHsQuote :: forall p. (OutputableBndrId p)
+ => HsQuote (GhcPass p) -> SDoc
+ pprHsQuote (ExpBr _ e) = thBrackets empty (ppr e)
+ pprHsQuote (PatBr _ p) = thBrackets (char 'p') (ppr p)
+ pprHsQuote (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)
+ pprHsQuote (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))
+ pprHsQuote (TypBr _ t) = thBrackets (char 't') (ppr t)
+ pprHsQuote (VarBr _ True n)
= char '\'' <> pprPrefixOcc (unLoc n)
- pprHsUntypedBracket (VarBr _ False n)
+ pprHsQuote (VarBr _ False n)
= text "''" <> pprPrefixOcc (unLoc n)
- pprHsUntypedBracket (XUntypedBracket b) = case ghcPass @p of
- #if __GLASGOW_HASKELL__ <= 900
+ pprHsQuote (XQuote b) = case ghcPass @p of
+#if __GLASGOW_HASKELL__ <= 900
GhcPs -> dataConCantHappen b
GhcRn -> dataConCantHappen b
- #endif
- GhcTc -> pprHsUntypedBracket b
+#endif
+ GhcTc -> pprHsQuote b
thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index fbfe0ea0ef..fef85d1c60 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -383,17 +383,12 @@ deriving instance Data (HsSplicedThing GhcPs)
deriving instance Data (HsSplicedThing GhcRn)
deriving instance Data (HsSplicedThing GhcTc)
--- deriving instance (DataIdLR p p) => Data (HsTypedBracket p)
-deriving instance Data (HsTypedBracket GhcPs)
-deriving instance Data (HsTypedBracket GhcRn)
-deriving instance Data (HsTypedBracket GhcTc)
+-- deriving instance (DataIdLR p p) => Data (HsQuote p)
+deriving instance Data (HsQuote GhcPs)
+deriving instance Data (HsQuote GhcRn)
+deriving instance Data (HsQuote GhcTc)
--- deriving instance (DataIdLR p p) => Data (HsUntypedBracket p)
-deriving instance Data (HsUntypedBracket GhcPs)
-deriving instance Data (HsUntypedBracket GhcRn)
-deriving instance Data (HsUntypedBracket GhcTc)
-
-deriving instance Data HsBracketTc
+deriving instance Data thing => Data (HsBracketTc thing)
-- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p)
deriving instance Data (ArithSeqInfo GhcPs)
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 5cf368027d..4952256baf 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -129,8 +129,8 @@ hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of
Nothing -> asi_ty
where
asi_ty = arithSeqInfoType asi
-hsExprType (HsTypedBracket (HsBracketTc ty _wrap _pending) _) = ty
-hsExprType (HsUntypedBracket (HsBracketTc ty _wrap _pending) _) = ty
+hsExprType (HsTypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty
+hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty
hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"
(ppr e)
-- Typed splices should have been eliminated during zonking, but we
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index d52e9f997b..1d471d6321 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -746,14 +746,11 @@ Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
-- Here is where we desugar the Template Haskell brackets and escapes
-- Template Haskell stuff
+-- See Note [The life cycle of a TH quotation]
-dsExpr (HsTypedBracket (HsBracketTc _ hs_wrapper ps) (XTypedBracket x)) = dsTypedBracket hs_wrapper x ps
- -- ^ See Note [Desugaring typed brackets] in GHC.Hs.Expr on why XTypedBracket -- romes TODO:
-dsExpr (HsTypedBracket (HsBracketTc _ _ ps) _) = pprPanic "dsExpr:typed_bracket" (ppr ps)
-dsExpr (HsUntypedBracket (HsBracketTc _ hs_wrapper ps) (XUntypedBracket x)) = dsUntypedBracket hs_wrapper x ps
- -- ^ See Note [Type-checking untyped brackets] in GHC.Hs.Expr on why XUntypedBracket
-dsExpr (HsUntypedBracket (HsBracketTc _ _ ps) _) = pprPanic "dsExpr:untyped_bracket" (ppr ps)
-dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
+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 (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
-- Arrow notation extension
dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index b4767dc679..0f6eb9442e 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -158,13 +158,13 @@ getPlatform = targetPlatform <$> getDynFlags
-----------------------------------------------------------------------------
dsTypedBracket :: Maybe QuoteWrapper
- -> HsTypedBracket GhcRn
+ -> LHsExpr GhcRn -- See Note [The life cycle of a TH quotation]
-> [PendingTcSplice]
-> DsM CoreExpr
-dsTypedBracket wrap (TExpBr _ exp) splices
+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?
+ -- 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
@@ -173,7 +173,7 @@ dsTypedBracket wrap (TExpBr _ exp) splices
runReaderT (mapReaderT (dsExtendMetaEnv (new_bit splices)) act) mw
dsUntypedBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr
- -> HsUntypedBracket GhcRn
+ -> HsQuote GhcRn -- See Note [The life cycle of a TH quotation]
-> [PendingTcSplice]
-> DsM CoreExpr
-- See Note [Desugaring Brackets]
@@ -184,7 +184,7 @@ dsUntypedBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dea
dsUntypedBracket wrap brack splices
= do_brack brack
where
- -- ROMES: TODO: factoring this method out requires many imports for its explicit type, is it worth it?
+ -- 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
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index c825c46a01..9ce99f3fdb 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1184,10 +1184,10 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
[ toHie expr
]
HsTypedBracket xbracket b -> case hiePass @p of
- HieRn | _ <- xbracket ->
- [ toHie b
- ]
- HieTc | HsBracketTc _ _ p <- xbracket ->
+ HieRn ->
+ [ toHie b
+ ]
+ HieTc | HsBracketTc _ _ _ p <- xbracket ->
[ toHie b
, toHie p
]
@@ -1196,7 +1196,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
[ toHie b
, toHie p
]
- HieTc | HsBracketTc _ _ p <- xbracket ->
+ HieTc | HsBracketTc _ _ _ p <- xbracket ->
[ toHie b
, toHie p
]
@@ -1859,10 +1859,7 @@ instance ToHie (LocatedA (SpliceDecl GhcRn)) where
[ toHie splice
]
-instance ToHie (HsTypedBracket a) where
- toHie _ = pure []
-
-instance ToHie (HsUntypedBracket a) where
+instance ToHie (HsQuote a) where
toHie _ = pure []
instance ToHie PendingRnSplice where
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 3a016e00de..ce1c48b99d 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2929,7 +2929,7 @@ aexp2 :: { ECP }
else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) cs) (ExpBr noExtField $2)) }
| '[||' exp '||]' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsTypedBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) (TExpBr noExtField $2)) }
+ acsA (\cs -> sLL $1 $> $ HsTypedBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) $2) }
| '[t|' ktype '|]' {% fmap ecpFromExp $
acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) }
| '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index 8993442711..bf46b89cc9 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -73,8 +73,8 @@ import qualified GHC.LanguageExtensions as LangExt
************************************************************************
-}
-rnTypedBracket :: HsExpr GhcPs -> HsTypedBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-rnTypedBracket e (TExpBr ext br_body)
+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
@@ -103,11 +103,11 @@ rnTypedBracket e (TExpBr ext br_body)
; traceRn "Renaming typed TH bracket" empty
; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body
- ; return (HsTypedBracket noAnn (TExpBr ext body'), fvs_e)
+ ; return (HsTypedBracket noAnn body', fvs_e)
}
-rnUntypedBracket :: HsExpr GhcPs -> HsUntypedBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+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
@@ -146,7 +146,7 @@ rnUntypedBracket e br_body
}
-rn_utbracket :: ThStage -> HsUntypedBracket GhcPs -> RnM (HsUntypedBracket GhcRn, FreeVars)
+rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)
rn_utbracket outer_stage br@(VarBr x flg rdr_name)
= do { name <- lookupOccRn (unLoc rdr_name)
; check_namespace flg name
@@ -224,7 +224,7 @@ typedQuotationCtxtDoc br_body
= hang (text "In the Template Haskell typed quotation")
2 (thTyBrackets . ppr $ br_body)
-untypedQuotationCtxtDoc :: HsUntypedBracket GhcPs -> SDoc
+untypedQuotationCtxtDoc :: HsQuote GhcPs -> SDoc
untypedQuotationCtxtDoc br_body
= hang (text "In the Template Haskell quotation")
2 (ppr br_body)
@@ -242,7 +242,7 @@ illegalUntypedBracket :: TcRnMessage
illegalUntypedBracket = TcRnUnknownMessage $ mkPlainError noHints $
text "Untyped brackets may only appear in untyped splices."
-quotedNameStageErr :: HsUntypedBracket GhcPs -> TcRnMessage
+quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage
quotedNameStageErr br
= TcRnUnknownMessage $ mkPlainError noHints $
sep [ text "Stage error: the non-top-level quoted name" <+> ppr br
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 526c18706a..35375bc5a5 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1635,7 +1635,7 @@ gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
(map (pats_etc mk_typed_bracket mk_tsplice liftTypedName) data_cons)
mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField
- mk_typed_bracket = HsTypedBracket noAnn . TExpBr noExtField
+ mk_typed_bracket = HsTypedBracket noAnn
mk_usplice = HsUntypedSplice EpAnnNotUsed DollarSplice
mk_tsplice = HsTypedSplice EpAnnNotUsed DollarSplice
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 09b5e070ad..bed8e14161 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -163,8 +163,8 @@ import Data.Proxy ( Proxy (..) )
************************************************************************
-}
-tcTypedBracket :: HsExpr GhcRn -> HsTypedBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-tcUntypedBracket :: HsExpr GhcRn -> HsUntypedBracket GhcRn -> [PendingRnSplice] -> ExpRhoType
+tcTypedBracket :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+tcUntypedBracket :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType
-> TcM (HsExpr GhcTc)
tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- None of these functions add constraints to the LIE
@@ -184,8 +184,8 @@ runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
-}
-- See Note [How brackets and nested splices are handled]
-tcTypedBracket rn_expr e@(TExpBr ext expr) res_ty
- = addErrCtxt (quotationCtxtDoc e) $
+tcTypedBracket rn_expr expr res_ty
+ = addErrCtxt (quotationCtxtDoc expr) $
do { cur_stage <- getStage
; ps_ref <- newMutVar []
; lie_var <- getConstraintVar -- Any constraints arising from nested splices
@@ -200,13 +200,20 @@ tcTypedBracket rn_expr e@(TExpBr ext expr) res_ty
-- brackets.
; let wrapper = QuoteWrapper ev_var m_var
-- Typecheck expr to make sure it is valid,
- -- Throw away the typechecked expression but return its type.
+ --
+ -- romes TODO: The following is not actually that true: ppr_expr in
+ -- GHC.Hs.Expr uses this (and for untyped brackets the supposedly not
+ -- used type is also used).
+ -- If it isn't to be used, should the types enforce that?
+ --
+ -- The typechecked expression won't be used, but we return it with its type.
+ -- (See Note [The life cycle of a TH quotation] in GHC.Hs.Expr)
-- We'll typecheck it again when we splice it in somewhere
- ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $
- tcScalingUsage Many $
- -- Scale by Many, TH lifting is currently nonlinear (#18465)
- tcInferRhoNC expr
- -- NC for no context; tcBracket does that
+ ; (tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $
+ tcScalingUsage Many $
+ -- Scale by Many, TH lifting is currently nonlinear (#18465)
+ tcInferRhoNC expr
+ -- NC for no context; tcBracket does that
; let rep = getRuntimeRep expr_ty
; meta_ty <- tcTExpTy m_var expr_ty
; ps' <- readMutVar ps_ref
@@ -216,7 +223,7 @@ tcTypedBracket rn_expr e@(TExpBr ext expr) res_ty
rn_expr
(unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)
(nlHsTyApp codeco [rep, expr_ty]))
- (noLocA (HsTypedBracket (HsBracketTc bracket_ty (Just wrapper) ps') (XTypedBracket (TExpBr ext expr))))))
+ (noLocA (HsTypedBracket (HsBracketTc expr bracket_ty (Just wrapper) ps') tc_expr))))
meta_ty res_ty }
-- See Note [Typechecking Overloaded Quotes]
@@ -242,7 +249,7 @@ tcUntypedBracket rn_expr brack ps res_ty
-- Unify the overall type of the bracket with the expected result
-- type
; tcWrapResultO BracketOrigin rn_expr
- (HsUntypedBracket (HsBracketTc expected_type brack_info ps') (XUntypedBracket brack))
+ (HsUntypedBracket (HsBracketTc brack expected_type brack_info ps') (XQuote brack))
expected_type res_ty
}
@@ -264,7 +271,7 @@ emitQuoteWanted m_var = do
-- | Compute the expected type of a quotation, and also the QuoteWrapper in
-- the case where it is an overloaded quotation. All quotation forms are
-- overloaded aprt from Variable quotations ('foo)
-brackTy :: HsUntypedBracket GhcRn -> TcM (Maybe QuoteWrapper, Type)
+brackTy :: HsQuote GhcRn -> TcM (Maybe QuoteWrapper, Type)
brackTy b =
let mkTy n = do
-- New polymorphic type variable for the bracket
@@ -324,10 +331,10 @@ tcTExpTy m_ty exp_ty
, text "The type of a Typed Template Haskell expression must" <+>
text "not have any quantification." ]
-quotationCtxtDoc :: HsTypedBracket GhcRn -> SDoc
+quotationCtxtDoc :: LHsExpr GhcRn -> SDoc
quotationCtxtDoc br_body
= hang (text "In the Template Haskell quotation")
- 2 (ppr br_body)
+ 2 (thTyBrackets . ppr $ br_body)
-- The whole of the rest of the file is the else-branch (ie stage2 only)
@@ -377,6 +384,7 @@ The life cycle of a typed bracket:
* Result is a HsTcBracketOut rn_brack pending_splices
where rn_brack is the incoming renamed bracket
+-- romes TODO update note
The life cycle of a un-typed bracket:
* Starts as HsBracket
diff --git a/compiler/GHC/Tc/Gen/Splice.hs-boot b/compiler/GHC/Tc/Gen/Splice.hs-boot
index 68efb320a8..c4cd5f70df 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs-boot
+++ b/compiler/GHC/Tc/Gen/Splice.hs-boot
@@ -10,8 +10,8 @@ import GHC.Tc.Utils.TcType ( ExpRhoType )
import GHC.Types.Annotations ( Annotation, CoreAnnTarget )
import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc )
-import GHC.Hs ( HsSplice, HsTypedBracket, HsUntypedBracket, HsExpr,
- LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers )
+import GHC.Hs ( HsSplice, HsQuote, HsExpr, LHsExpr, LHsType,
+ LPat, LHsDecl, ThModFinalizers )
import qualified Language.Haskell.TH as TH
tcSpliceExpr :: HsSplice GhcRn
@@ -19,11 +19,11 @@ tcSpliceExpr :: HsSplice GhcRn
-> TcM (HsExpr GhcTc)
tcTypedBracket :: HsExpr GhcRn
- -> HsTypedBracket GhcRn
+ -> LHsExpr GhcRn
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcUntypedBracket :: HsExpr GhcRn
- -> HsUntypedBracket GhcRn
+ -> HsQuote GhcRn
-> [PendingRnSplice]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 2c62dda556..45e6ec9a02 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -778,11 +778,12 @@ zonkExpr env (HsAppType ty e t)
return (HsAppType new_ty new_e t)
-- NB: the type is an HsType; can't zonk that!
-zonkExpr env (HsTypedBracket (HsBracketTc ty wrap bs) body)
+-- 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 new_ty wrap' bs') body)
+ return (HsTypedBracket (HsBracketTc hsb_thing new_ty wrap' bs') body)
where
zonkQuoteWrap (QuoteWrapper ev ty) = do
let ev' = zonkIdOcc env ev
@@ -792,11 +793,11 @@ zonkExpr env (HsTypedBracket (HsBracketTc ty wrap bs) body)
zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
return (PendingTcSplice n e')
-zonkExpr env (HsUntypedBracket (HsBracketTc ty wrap bs) body)
+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 new_ty wrap' bs') body)
+ return (HsUntypedBracket (HsBracketTc hsb_thing new_ty wrap' bs') body)
where
zonkQuoteWrap (QuoteWrapper ev ty) = do
let ev' = zonkIdOcc env ev
View Lorry Controller Status