summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Expr.hs135
-rw-r--r--compiler/GHC/Hs/Instances.hs15
-rw-r--r--compiler/GHC/Hs/Syn/Type.hs3
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs3
-rw-r--r--compiler/GHC/HsToCore/Expr.hs8
-rw-r--r--compiler/GHC/HsToCore/Quote.hs46
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs17
-rw-r--r--compiler/GHC/Parser.y18
-rw-r--r--compiler/GHC/Rename/Expr.hs5
-rw-r--r--compiler/GHC/Rename/Splice.hs111
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs10
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs5
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs23
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs-boot14
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs3
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs18
-rw-r--r--compiler/Language/Haskell/Syntax/Expr.hs23
-rw-r--r--compiler/Language/Haskell/Syntax/Extension.hs23
-rw-r--r--utils/check-exact/ExactPrint.hs26
19 files changed, 299 insertions, 207 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index b9c9c12415..5dfff39437 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -187,17 +187,6 @@ type instance HsDoRn (GhcPass _) = GhcRn
-- ---------------------------------------------------------------------
- -- See Note [Pending Splices]
-data HsBracketRn
- = HsBracketRnTyped
- (EpAnn [AddEpAnn])
-
- | HsBracketRnUntyped
- (EpAnn [AddEpAnn])
- [PendingRnSplice] -- Output of the renamer is the *original* renamed
- -- expression, plus
- -- _renamed_ splices to be type checked
-
data HsBracketTc = HsBracketTc
Type
(Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument
@@ -207,9 +196,16 @@ data HsBracketTc = HsBracketTc
-- _typechecked_ splices to be
-- pasted back in by the desugarer
-type instance XBracket GhcPs = EpAnn [AddEpAnn]
-type instance XBracket GhcRn = HsBracketRn
-type instance XBracket GhcTc = HsBracketTc
+type instance XTypedBracket GhcPs = EpAnn [AddEpAnn]
+type instance XTypedBracket GhcRn = EpAnn [AddEpAnn]
+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
-- ---------------------------------------------------------------------
@@ -653,13 +649,19 @@ ppr_expr (ExprWithTySig _ expr sig)
ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
ppr_expr (HsSpliceE _ s) = pprSplice s
-ppr_expr (HsBracket b e)
+ppr_expr (HsTypedBracket b e)
= case ghcPass @p of
- GhcPs -> pprHsBracket e
+ 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)
+ = case ghcPass @p of
+ GhcPs -> ppr e
GhcRn -> case b of
- HsBracketRnTyped _ -> pprHsBracket e
- HsBracketRnUntyped _ [] -> ppr e
- HsBracketRnUntyped _ ps -> ppr e $$ text "pending(rn)" <+> ppr ps
+ (_, []) -> 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)
@@ -802,7 +804,8 @@ hsExprNeedsParens prec = go
go (ArithSeq{}) = False
go (HsPragE{}) = prec >= appPrec
go (HsSpliceE{}) = False
- go (HsBracket{}) = False
+ go (HsTypedBracket{}) = False
+ go (HsUntypedBracket{}) = False
go (HsProc{}) = prec > topPrec
go (HsStatic{}) = prec >= appPrec
go (RecordCon{}) = False
@@ -1665,12 +1668,12 @@ bracket code. So for example
[| f $(g x) |]
looks like
- HsBracket _ (HsApp (HsVar "f") (HsSpliceE _ (g x)))
+ HsUntypedBracket _ (HsApp (HsVar "f") (HsSpliceE _ (g x)))
which the renamer rewrites to
- HsBracket
- (HsBracketRnUnTyped _ [PendingRnSplice UntypedExpSplice sn (g x)])
+ HsUntypedBracket
+ (_, [PendingRnSplice UntypedExpSplice sn (g x)])
(HsApp (HsVar f) (HsSpliceE sn (g x)))
* The 'sn' is the Name of the splice point, the SplicePointName
@@ -1777,59 +1780,71 @@ ppr_splice herald n e trail
Note [Type-checking untyped brackets]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we type-check an untyped bracket, the actual bracket (the second argument
-of the HsBracket constructor in HsExpr) is kept in the renaming pass.
+of the HsUntypedBracket constructor in HsExpr) is kept in the renaming pass.
Given that
HsExpr p = ...
- | HsBracket (XBracket p) (HsBracket p)
+ | HsUntypedBracket (XUntypedBracket p) (HsUntypedBracket p)
-When p = GhcPs we should have HsExpr GhcPs and HsBracket GhcPs
-When p = GhcRn we should have HsExpr GhcRn and HsBracket GhcRn
-However, when p = GhcRn we should have HsExpr GhcTc and HsBracket GhcRn
+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 HsBracket extension constructor (XBracket !(XXBracket p)),
-when p = GhcTc, is used to hold the needed HsBracket 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 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 XTExpBr (GhcPass _) = NoExtField
-type instance XXBracket GhcPs = DataConCantHappen
-type instance XXBracket GhcRn = DataConCantHappen
-type instance XXBracket GhcTc = HsBracket GhcRn -- See Note [Type-checking untyped brackets]
+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]
instance OutputableBndrId p
- => Outputable (HsBracket (GhcPass p)) where
- ppr = pprHsBracket
-
-
-pprHsBracket :: forall p. (OutputableBndrId p)
- => HsBracket (GhcPass p) -> SDoc
-pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e)
-pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p)
-pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)
-pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))
-pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t)
-pprHsBracket (VarBr _ True n)
- = char '\'' <> pprPrefixOcc (unLoc n)
-pprHsBracket (VarBr _ False n)
- = text "''" <> pprPrefixOcc (unLoc n)
-pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e)
-pprHsBracket (XBracket b) = case ghcPass @p of
+ => 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
+ GhcPs -> dataConCantHappen b
+ GhcRn -> dataConCantHappen b
#endif
- GhcTc -> pprHsBracket b
+ GhcTc | (TExpBr _ e) <- b -> thTyBrackets (ppr e)
+
+instance OutputableBndrId p
+ => Outputable (HsUntypedBracket (GhcPass p)) where
+ ppr = pprHsUntypedBracket
+ 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)
+ = char '\'' <> pprPrefixOcc (unLoc n)
+ pprHsUntypedBracket (VarBr _ False n)
+ = text "''" <> pprPrefixOcc (unLoc n)
+ pprHsUntypedBracket (XUntypedBracket b) = case ghcPass @p of
+ #if __GLASGOW_HASKELL__ <= 900
+ GhcPs -> dataConCantHappen b
+ GhcRn -> dataConCantHappen b
+ #endif
+ GhcTc -> pprHsUntypedBracket 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 f93df4ac67..fbfe0ea0ef 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -383,12 +383,15 @@ deriving instance Data (HsSplicedThing GhcPs)
deriving instance Data (HsSplicedThing GhcRn)
deriving instance Data (HsSplicedThing GhcTc)
--- deriving instance (DataIdLR p p) => Data (HsBracket p)
-deriving instance Data (HsBracket GhcPs)
-deriving instance Data (HsBracket GhcRn)
-deriving instance Data (HsBracket GhcTc)
-
-deriving instance Data HsBracketRn
+-- 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 (HsUntypedBracket p)
+deriving instance Data (HsUntypedBracket GhcPs)
+deriving instance Data (HsUntypedBracket GhcRn)
+deriving instance Data (HsUntypedBracket GhcTc)
deriving instance Data HsBracketTc
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index a57cd80145..5cf368027d 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -129,7 +129,8 @@ hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of
Nothing -> asi_ty
where
asi_ty = arithSeqInfoType asi
-hsExprType (HsBracket (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/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index 9fcfd9a81e..e1e8489fe1 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -638,7 +638,8 @@ addTickHsExpr (ArithSeq ty wit arith_seq) =
addTickHsExpr (HsPragE x p e) =
liftM (HsPragE x p) (addTickLHsExpr e)
-addTickHsExpr e@(HsBracket {}) = return e
+addTickHsExpr e@(HsTypedBracket {}) = return e
+addTickHsExpr e@(HsUntypedBracket{}) = return e
addTickHsExpr e@(HsSpliceE {}) = return e
addTickHsExpr e@(HsGetField {}) = return e
addTickHsExpr e@(HsProjection {}) = return e
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 1691db72a9..d52e9f997b 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -747,8 +747,12 @@ Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
-- Template Haskell stuff
-dsExpr (HsBracket (HsBracketTc _ hs_wrapper ps) (XBracket x)) = dsBracket hs_wrapper x ps -- See Note [Type-checking untyped brackets] in GHC.Hs.Expr
-dsExpr (HsBracket (HsBracketTc _ _ ps) _) = pprPanic "dsExpr:bracket" (ppr ps)
+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)
-- Arrow notation extension
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 6c8b113dec..b4767dc679 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( dsBracket ) where
+module GHC.HsToCore.Quote( dsTypedBracket, dsUntypedBracket ) where
import GHC.Prelude
import GHC.Platform
@@ -157,37 +157,52 @@ getPlatform :: MetaM Platform
getPlatform = targetPlatform <$> getDynFlags
-----------------------------------------------------------------------------
-dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr
- -> HsBracket GhcRn
- -> [PendingTcSplice]
- -> DsM CoreExpr
+dsTypedBracket :: Maybe QuoteWrapper
+ -> HsTypedBracket GhcRn
+ -> [PendingTcSplice]
+ -> DsM CoreExpr
+dsTypedBracket wrap (TExpBr _ 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
+ -> HsUntypedBracket GhcRn
+ -> [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!
-dsBracket wrap brack splices
+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?
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) act) mw
-
-
- new_bit = mkNameEnv [(n, DsSplice (unLoc e))
- | PendingTcSplice n e <- splices]
+ runReaderT (mapReaderT (dsExtendMetaEnv (new_bit splices)) act) mw
do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM (unLoc n) ; return e1 }
do_brack (ExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 }
do_brack (PatBr _ p) = runOverloaded $ do { MkC p1 <- repTopP p ; return p1 }
do_brack (TypBr _ t) = runOverloaded $ do { MkC t1 <- repLTy t ; return t1 }
do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
- do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL"
- do_brack (TExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 }
+ 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]
@@ -1636,7 +1651,8 @@ repE (XExpr (HsExpanded orig_expr ds_expr))
then repE ds_expr
else repE orig_expr }
repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
-repE e@(HsBracket{}) = notHandled (ThExpressionForm e)
+repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e)
+repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsProc{}) = notHandled (ThExpressionForm e)
{- Note [Quotation and rebindable syntax]
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 3aba40407b..c825c46a01 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1183,12 +1183,16 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
HsStatic _ expr ->
[ toHie expr
]
- HsBracket xbracket b -> case hiePass @p of
- HieRn -> case xbracket of
- HsBracketRnTyped _ ->
+ HsTypedBracket xbracket b -> case hiePass @p of
+ HieRn | _ <- xbracket ->
[ toHie b
]
- HsBracketRnUntyped _ p ->
+ HieTc | HsBracketTc _ _ p <- xbracket ->
+ [ toHie b
+ , toHie p
+ ]
+ HsUntypedBracket xbracket b -> case hiePass @p of
+ HieRn | (_, p) <- xbracket ->
[ toHie b
, toHie p
]
@@ -1855,7 +1859,10 @@ instance ToHie (LocatedA (SpliceDecl GhcRn)) where
[ toHie splice
]
-instance ToHie (HsBracket a) where
+instance ToHie (HsTypedBracket a) where
+ toHie _ = pure []
+
+instance ToHie (HsUntypedBracket a) where
toHie _ = pure []
instance ToHie PendingRnSplice where
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 24ef753453..3a016e00de 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2917,26 +2917,26 @@ aexp2 :: { ECP }
| splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }
| splice_typed { ecpFromExp $ mapLoc (HsSpliceE noAnn) (reLocA $1) }
- | SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
- | SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
- | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
- | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
+ | SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
+ | SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
+ | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
+ | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) }
-- See Note [%shift: aexp2 -> TH_TY_QUOTE]
| TH_TY_QUOTE %shift {% reportEmptyDoubleQuotes (getLoc $1) }
| '[|' exp '|]' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
+ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]
else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) cs) (ExpBr noExtField $2)) }
| '[||' exp '||]' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsBracket (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) (TExpBr noExtField $2)) }
| '[t|' ktype '|]' {% fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) }
+ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) }
| '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->
fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (PatBr noExtField p)) }
+ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (PatBr noExtField p)) }
| '[d|' cvtopbody '|]' {% fmap ecpFromExp $
- acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) }
+ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) }
| quasiquote { ECP $ pvA $ mkHsSplicePV $1 }
-- arrow notation extension
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 6c7a55da1f..f1cb766077 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -47,7 +47,7 @@ import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames
, genHsVar, genLHsVar, genHsApp, genHsApps
, genAppType )
import GHC.Rename.Unbound ( reportUnboundName )
-import GHC.Rename.Splice ( rnBracket, rnSpliceExpr, checkThLocalName )
+import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnSpliceExpr, checkThLocalName )
import GHC.Rename.HsType
import GHC.Rename.Pat
import GHC.Driver.Session
@@ -337,7 +337,8 @@ rnExpr (HsProjection _ fs)
------------------------------------------
-- Template Haskell extensions
-rnExpr e@(HsBracket _ br_body) = rnBracket e br_body
+rnExpr e@(HsTypedBracket _ br_body) = rnTypedBracket e br_body
+rnExpr e@(HsUntypedBracket _ br_body) = rnUntypedBracket e br_body
rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index aae22dfd93..8993442711 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -6,7 +6,7 @@
module GHC.Rename.Splice (
rnTopSpliceDecls,
rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
- rnBracket,
+ rnTypedBracket, rnUntypedBracket,
checkThLocalName
, traceSplice, SpliceInfo(..)
) where
@@ -73,9 +73,9 @@ import qualified GHC.LanguageExtensions as LangExt
************************************************************************
-}
-rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-rnBracket e br_body
- = addErrCtxt (quotationCtxtDoc br_body) $
+rnTypedBracket :: HsExpr GhcPs -> HsTypedBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+rnTypedBracket e (TExpBr ext br_body)
+ = addErrCtxt (typedQuotationCtxtDoc br_body) $
do { -- Check that -XTemplateHaskellQuotes is enabled and available
thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes
; unless thQuotesEnabled $
@@ -87,13 +87,11 @@ rnBracket e br_body
-- Check for nested brackets
; cur_stage <- getStage
; case cur_stage of
- { Splice Typed -> checkTc (isTypedBracket br_body)
- illegalUntypedBracket
- ; Splice Untyped -> checkTc (not (isTypedBracket br_body))
- illegalTypedBracket
+ { Splice Typed -> return ()
+ ; Splice Untyped -> failWithTc illegalTypedBracket
; RunSplice _ ->
-- See Note [RunSplice ThLevel] in GHC.Tc.Types.
- pprPanic "rnBracket: Renaming bracket when running a splice"
+ pprPanic "rnTypedBracket: Renaming typed bracket when running a splice"
(ppr e)
; Comp -> return ()
; Brack {} -> failWithTc illegalBracket
@@ -102,26 +100,54 @@ rnBracket e br_body
-- Brackets are desugared to code that mentions the TH package
; recordThUse
- ; case isTypedBracket br_body of
- True -> do { traceRn "Renaming typed TH bracket" empty
- ; (body', fvs_e) <-
- setStage (Brack cur_stage RnPendingTyped) $
- rn_bracket cur_stage br_body
- ; return (HsBracket (HsBracketRnTyped noAnn) body', fvs_e) }
-
- False -> do { traceRn "Renaming untyped TH bracket" empty
- ; ps_var <- newMutVar []
- ; (body', fvs_e) <-
- -- See Note [Rebindable syntax and Template Haskell]
- unsetXOptM LangExt.RebindableSyntax $
- setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
- rn_bracket cur_stage br_body
- ; pendings <- readMutVar ps_var
- ; return (HsBracket (HsBracketRnUntyped noAnn pendings) body', fvs_e) }
+ ; 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)
+
}
-rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)
-rn_bracket outer_stage br@(VarBr x flg rdr_name)
+rnUntypedBracket :: HsExpr GhcPs -> HsUntypedBracket 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") ] )
+
+ -- Check for nested brackets
+ ; cur_stage <- getStage
+ ; case cur_stage of
+ { Splice Typed -> failWithTc illegalUntypedBracket
+ ; Splice Untyped -> return ()
+ ; RunSplice _ ->
+ -- See Note [RunSplice ThLevel] in GHC.Tc.Types.
+ pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice"
+ (ppr e)
+ ; Comp -> return ()
+ ; Brack {} -> failWithTc illegalBracket
+ }
+
+ -- Brackets are desugared to code that mentions the TH package
+ ; recordThUse
+
+ ; traceRn "Renaming untyped TH bracket" empty
+ ; ps_var <- newMutVar []
+ ; (body', fvs_e) <-
+ -- See Note [Rebindable syntax and Template Haskell]
+ unsetXOptM LangExt.RebindableSyntax $
+ setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
+ rn_utbracket cur_stage br_body
+ ; pendings <- readMutVar ps_var
+ ; return (HsUntypedBracket (noAnn, pendings) body', fvs_e)
+
+ }
+
+rn_utbracket :: ThStage -> HsUntypedBracket GhcPs -> RnM (HsUntypedBracket GhcRn, FreeVars)
+rn_utbracket outer_stage br@(VarBr x flg rdr_name)
= do { name <- lookupOccRn (unLoc rdr_name)
; check_namespace flg name
; this_mod <- getModule
@@ -137,7 +163,7 @@ rn_bracket outer_stage br@(VarBr x flg rdr_name)
| isTopLevel top_lvl
-> when (isExternalName name) (keepAlive name)
| otherwise
- -> do { traceRn "rn_bracket VarBr"
+ -> do { traceRn "rn_utbracket VarBr"
(ppr name <+> ppr bind_lvl
<+> ppr outer_stage)
; checkTc (thLevel outer_stage + 1 == bind_lvl)
@@ -146,16 +172,16 @@ rn_bracket outer_stage br@(VarBr x flg rdr_name)
}
; return (VarBr x flg (noLocA name), unitFV name) }
-rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
- ; return (ExpBr x e', fvs) }
+rn_utbracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
+ ; return (ExpBr x e', fvs) }
-rn_bracket _ (PatBr x p)
+rn_utbracket _ (PatBr x p)
= rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)
-rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t
- ; return (TypBr x t', fvs) }
+rn_utbracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t
+ ; return (TypBr x t', fvs) }
-rn_bracket _ (DecBrL x decls)
+rn_utbracket _ (DecBrL x decls)
= do { group <- groupDecls decls
; gbl_env <- getGblEnv
; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
@@ -165,7 +191,7 @@ rn_bracket _ (DecBrL x decls)
rnSrcDecls group
-- Discard the tcg_env; it contains only extra info about fixity
- ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$
+ ; traceRn "rn_utbracket dec" (ppr (tcg_dus tcg_env) $$
ppr (duUses (tcg_dus tcg_env)))
; return (DecBrG x group', duUses (tcg_dus tcg_env)) }
where
@@ -181,10 +207,8 @@ rn_bracket _ (DecBrL x decls)
}
}}
-rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"
+rn_utbracket _ (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG"
-rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e
- ; return (TExpBr x e', fvs) }
-- | Ensure that we are not using a term-level name in a type-level namespace
-- or vice-versa. Throws a 'TcRnIncorrectNameSpace' error if there is a problem.
@@ -195,8 +219,13 @@ check_namespace is_single_tick nm
where
ns = nameNameSpace nm
-quotationCtxtDoc :: HsBracket GhcPs -> SDoc
-quotationCtxtDoc br_body
+typedQuotationCtxtDoc :: LHsExpr GhcPs -> SDoc
+typedQuotationCtxtDoc br_body
+ = hang (text "In the Template Haskell typed quotation")
+ 2 (thTyBrackets . ppr $ br_body)
+
+untypedQuotationCtxtDoc :: HsUntypedBracket GhcPs -> SDoc
+untypedQuotationCtxtDoc br_body
= hang (text "In the Template Haskell quotation")
2 (ppr br_body)
@@ -213,7 +242,7 @@ illegalUntypedBracket :: TcRnMessage
illegalUntypedBracket = TcRnUnknownMessage $ mkPlainError noHints $
text "Untyped brackets may only appear in untyped splices."
-quotedNameStageErr :: HsBracket GhcPs -> TcRnMessage
+quotedNameStageErr :: HsUntypedBracket 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 d61ad20707..526c18706a 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1630,12 +1630,12 @@ gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
(listToBag [lift_bind, liftTyped_bind], emptyBag)
where
lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
- (map (pats_etc mk_exp mk_usplice liftName) data_cons)
+ (map (pats_etc mk_untyped_bracket mk_usplice liftName) data_cons)
liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)
- (map (pats_etc mk_texp mk_tsplice liftTypedName) data_cons)
+ (map (pats_etc mk_typed_bracket mk_tsplice liftTypedName) data_cons)
- mk_exp = ExpBr noExtField
- mk_texp = TExpBr noExtField
+ mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField
+ mk_typed_bracket = HsTypedBracket noAnn . TExpBr noExtField
mk_usplice = HsUntypedSplice EpAnnNotUsed DollarSplice
mk_tsplice = HsTypedSplice EpAnnNotUsed DollarSplice
@@ -1648,7 +1648,7 @@ gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
data_con_RDR = getRdrName data_con
con_arity = dataConSourceArity data_con
as_needed = take con_arity as_RDRs
- lift_Expr = noLocA (HsBracket noAnn (mk_bracket br_body))
+ lift_Expr = noLocA (mk_bracket br_body)
br_body = nlHsApps (Exact (dataConName data_con))
(map lift_var as_needed)
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 6dadf6286c..93bbdaafa6 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -861,9 +861,8 @@ tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))
= do addModFinalizersWithLclEnv mod_finalizers
tcExpr expr res_ty
tcExpr (HsSpliceE _ splice) res_ty = tcSpliceExpr splice res_ty
-tcExpr e@(HsBracket brack body) res_ty = case brack of
- HsBracketRnTyped _ -> tcTypedBracket e body res_ty
- HsBracketRnUntyped _ ps -> tcUntypedBracket e body ps 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
{-
************************************************************************
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 5acffaca7d..09b5e070ad 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 -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType
+tcTypedBracket :: HsExpr GhcRn -> HsTypedBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+tcUntypedBracket :: HsExpr GhcRn -> HsUntypedBracket GhcRn -> [PendingRnSplice] -> ExpRhoType
-> TcM (HsExpr GhcTc)
tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- None of these functions add constraints to the LIE
@@ -184,9 +184,8 @@ runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
-}
-- See Note [How brackets and nested splices are handled]
--- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
-tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
- = addErrCtxt (quotationCtxtDoc brack) $
+tcTypedBracket rn_expr e@(TExpBr ext expr) res_ty
+ = addErrCtxt (quotationCtxtDoc e) $
do { cur_stage <- getStage
; ps_ref <- newMutVar []
; lie_var <- getConstraintVar -- Any constraints arising from nested splices
@@ -213,16 +212,13 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
; ps' <- readMutVar ps_ref
; codeco <- tcLookupId unsafeCodeCoerceName
; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName
- ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
+ ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") -- romes TODO: What is Shouldn'tHappenOrigin? Is this still accurate?
rn_expr
(unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)
(nlHsTyApp codeco [rep, expr_ty]))
- (noLocA (HsBracket (HsBracketTc bracket_ty (Just wrapper) ps') (XBracket brack)))))
+ (noLocA (HsTypedBracket (HsBracketTc bracket_ty (Just wrapper) ps') (XTypedBracket (TExpBr ext expr))))))
meta_ty res_ty }
-tcTypedBracket _ other_brack _
- = pprPanic "tcTypedBracket" (ppr other_brack)
--- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)
-- See Note [Typechecking Overloaded Quotes]
tcUntypedBracket rn_expr brack ps res_ty
= do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
@@ -246,7 +242,7 @@ tcUntypedBracket rn_expr brack ps res_ty
-- Unify the overall type of the bracket with the expected result
-- type
; tcWrapResultO BracketOrigin rn_expr
- (HsBracket (HsBracketTc expected_type brack_info ps') (XBracket brack))
+ (HsUntypedBracket (HsBracketTc expected_type brack_info ps') (XUntypedBracket brack))
expected_type res_ty
}
@@ -268,7 +264,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 :: HsBracket GhcRn -> TcM (Maybe QuoteWrapper, Type)
+brackTy :: HsUntypedBracket GhcRn -> TcM (Maybe QuoteWrapper, Type)
brackTy b =
let mkTy n = do
-- New polymorphic type variable for the bracket
@@ -291,7 +287,6 @@ brackTy b =
(DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec]
(PatBr {}) -> mkTy patTyConName -- Result type is m Pat
(DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL"
- (TExpBr {}) -> panic "tcUntypedBracket: Unexpected TExpBr"
---------------
-- | Typechecking a pending splice from a untyped bracket
@@ -329,7 +324,7 @@ tcTExpTy m_ty exp_ty
, text "The type of a Typed Template Haskell expression must" <+>
text "not have any quantification." ]
-quotationCtxtDoc :: HsBracket GhcRn -> SDoc
+quotationCtxtDoc :: HsTypedBracket GhcRn -> SDoc
quotationCtxtDoc br_body
= hang (text "In the Template Haskell quotation")
2 (ppr br_body)
diff --git a/compiler/GHC/Tc/Gen/Splice.hs-boot b/compiler/GHC/Tc/Gen/Splice.hs-boot
index 54dd1d0251..68efb320a8 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs-boot
+++ b/compiler/GHC/Tc/Gen/Splice.hs-boot
@@ -10,23 +10,23 @@ import GHC.Tc.Utils.TcType ( ExpRhoType )
import GHC.Types.Annotations ( Annotation, CoreAnnTarget )
import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc )
-import GHC.Hs ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,
- LHsDecl, ThModFinalizers )
+import GHC.Hs ( HsSplice, HsTypedBracket, HsUntypedBracket, HsExpr,
+ LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers )
import qualified Language.Haskell.TH as TH
tcSpliceExpr :: HsSplice GhcRn
-> ExpRhoType
-> TcM (HsExpr GhcTc)
+tcTypedBracket :: HsExpr GhcRn
+ -> HsTypedBracket GhcRn
+ -> ExpRhoType
+ -> TcM (HsExpr GhcTc)
tcUntypedBracket :: HsExpr GhcRn
- -> HsBracket GhcRn
+ -> HsUntypedBracket GhcRn
-> [PendingRnSplice]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
-tcTypedBracket :: HsExpr GhcRn
- -> HsBracket GhcRn
- -> ExpRhoType
- -> TcM (HsExpr GhcTc)
runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index b8ec635bd4..55730e20d1 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -705,7 +705,8 @@ exprCtOrigin (RecordUpd {}) = RecordUpdOrigin
exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin
exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence"
exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e
-exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket"
+exprCtOrigin (HsTypedBracket {}) = Shouldn'tHappenOrigin "TH typed bracket"
+exprCtOrigin (HsUntypedBracket {}) = Shouldn'tHappenOrigin "TH untyped bracket"
exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 0628ab428c..2c62dda556 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -778,11 +778,25 @@ 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 (HsBracket (HsBracketTc ty wrap bs) body)
+zonkExpr env (HsTypedBracket (HsBracketTc ty wrap bs) body)
= do wrap' <- traverse zonkQuoteWrap wrap
bs' <- mapM (zonk_b env) bs
new_ty <- zonkTcTypeToTypeX env ty
- return (HsBracket (HsBracketTc new_ty wrap' bs') body)
+ return (HsTypedBracket (HsBracketTc 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 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)
where
zonkQuoteWrap (QuoteWrapper ev ty) = do
let ev' = zonkIdOcc env ev
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index dd3e8b4545..0d4b3251a0 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -593,7 +593,8 @@ data HsExpr p
-- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnCloseQ'
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
- | HsBracket (XBracket p) (HsBracket p)
+ | HsTypedBracket (XTypedBracket p) (HsTypedBracket p)
+ | HsUntypedBracket (XUntypedBracket p) (HsUntypedBracket p)
-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
-- 'GHC.Parser.Annotation.AnnClose'
@@ -1604,22 +1605,22 @@ data UntypedSpliceFlavour
| UntypedDeclSplice
deriving Data
--- | Haskell Bracket
-data HsBracket p
- = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |]
+-- | Haskell Typed Bracket
+data HsTypedBracket p
+ = TExpBr (XTExpBr p) (LHsExpr p) -- [|| texp ||]
+ | XTypedBracket !(XXTypedBracket p) -- Extension point; see Note [Trees That Grow]
+ -- in Language.Haskell.Syntax.Extension
+-- | Haskell Untyped Bracket
+data HsUntypedBracket p
+ = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |]
| PatBr (XPatBr p) (LPat p) -- [p| pat |]
| DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser
| DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer
| TypBr (XTypBr p) (LHsType p) -- [t| type |]
| VarBr (XVarBr p) Bool (LIdP p)
-- True: 'x, False: ''T
- | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||]
- | XBracket !(XXBracket p) -- Extension point; see Note [Trees That Grow]
- -- in Language.Haskell.Syntax.Extension
-
-isTypedBracket :: HsBracket id -> Bool
-isTypedBracket (TExpBr {}) = True
-isTypedBracket _ = False
+ | XUntypedBracket !(XXUntypedBracket p) -- Extension point; see Note [Trees That Grow]
+ -- in Language.Haskell.Syntax.Extension
{-
************************************************************************
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 93c66fce35..df443eb451 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -429,7 +429,8 @@ type family XGetField x
type family XProjection x
type family XExprWithTySig x
type family XArithSeq x
-type family XBracket x
+type family XTypedBracket x
+type family XUntypedBracket x
type family XSpliceE x
type family XProc x
type family XStatic x
@@ -470,15 +471,17 @@ type family XSpliced x
type family XXSplice x
-- -------------------------------------
--- HsBracket type families
-type family XExpBr x
-type family XPatBr x
-type family XDecBrL x
-type family XDecBrG x
-type family XTypBr x
-type family XVarBr x
-type family XTExpBr x
-type family XXBracket x
+-- HsTypedBracket type families
+type family XTExpBr x
+type family XXTypedBracket x
+-- HsUntypedBracket type families
+type family XExpBr x
+type family XPatBr x
+type family XDecBrL x
+type family XDecBrG x
+type family XTypBr x
+type family XVarBr x
+type family XXUntypedBracket x
-- -------------------------------------
-- HsCmdTop type families
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index ee8130df3a..f5ff05bb1b 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -1845,7 +1845,8 @@ instance ExactPrint (HsExpr GhcPs) where
getAnnotationEntry (HsProjection an _) = fromAnn an
getAnnotationEntry (ExprWithTySig an _ _) = fromAnn an
getAnnotationEntry (ArithSeq an _ _) = fromAnn an
- getAnnotationEntry (HsBracket an _) = fromAnn an
+ getAnnotationEntry (HsTypedBracket an _) = fromAnn an
+ getAnnotationEntry (HsUntypedBracket an _) = fromAnn an
getAnnotationEntry (HsSpliceE an _) = fromAnn an
getAnnotationEntry (HsProc an _ _) = fromAnn an
getAnnotationEntry (HsStatic an _) = fromAnn an
@@ -2034,26 +2035,32 @@ instance ExactPrint (HsExpr GhcPs) where
markEpAnn an AnnCloseS -- ']'
- exact (HsBracket an (ExpBr _ e)) = do
+ exact (HsTypedBracket an (TExpBr _ e)) = do
+ markLocatedAALS an id AnnOpen (Just "[||")
+ markLocatedAALS an id AnnOpenE (Just "[e||")
+ markAnnotated e
+ markLocatedAALS an id AnnClose (Just "||]")
+
+ exact (HsUntypedBracket an (ExpBr _ e)) = do
markEpAnn an AnnOpenEQ -- "[|"
markEpAnn an AnnOpenE -- "[e|" -- optional
markAnnotated e
markEpAnn an AnnCloseQ -- "|]"
- exact (HsBracket an (PatBr _ e)) = do
+ exact (HsUntypedBracket an (PatBr _ e)) = do
markLocatedAALS an id AnnOpen (Just "[p|")
markAnnotated e
markEpAnn an AnnCloseQ -- "|]"
- exact (HsBracket an (DecBrL _ e)) = do
+ exact (HsUntypedBracket an (DecBrL _ e)) = do
markLocatedAALS an id AnnOpen (Just "[d|")
markAnnotated e
markEpAnn an AnnCloseQ -- "|]"
- -- -- exact (HsBracket an (DecBrG _ _)) =
+ -- -- exact (HsUntypedBracket an (DecBrG _ _)) =
-- -- traceM "warning: DecBrG introduced after renamer"
- exact (HsBracket an (TypBr _ e)) = do
+ exact (HsUntypedBracket an (TypBr _ e)) = do
markLocatedAALS an id AnnOpen (Just "[t|")
markAnnotated e
markEpAnn an AnnCloseQ -- "|]"
- exact (HsBracket an (VarBr _ b e)) = do
+ exact (HsUntypedBracket an (VarBr _ b e)) = do
if b
then do
markEpAnn an AnnSimpleQuote
@@ -2061,11 +2068,6 @@ instance ExactPrint (HsExpr GhcPs) where
else do
markEpAnn an AnnThTyQuote
markAnnotated e
- exact (HsBracket an (TExpBr _ e)) = do
- markLocatedAALS an id AnnOpen (Just "[||")
- markLocatedAALS an id AnnOpenE (Just "[e||")
- markAnnotated e
- markLocatedAALS an id AnnClose (Just "||]")
-- exact x@(HsRnBracketOut{}) = withPpr x
View Lorry Controller Status