summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/deSugar/Coverage.lhs7
-rw-r--r--compiler/deSugar/DsExpr.lhs6
-rw-r--r--compiler/deSugar/DsMeta.hs22
-rw-r--r--compiler/hsSyn/HsDecls.lhs4
-rw-r--r--compiler/hsSyn/HsExpr.lhs70
-rw-r--r--compiler/hsSyn/HsExpr.lhs-boot5
-rw-r--r--compiler/hsSyn/HsPat.lhs4
-rw-r--r--compiler/hsSyn/HsTypes.lhs6
-rw-r--r--compiler/hsSyn/HsUtils.lhs13
-rw-r--r--compiler/parser/RdrHsSyn.lhs23
-rw-r--r--compiler/rename/RnExpr.lhs4
-rw-r--r--compiler/rename/RnSplice.lhs354
-rw-r--r--compiler/rename/RnSplice.lhs-boot7
-rw-r--r--compiler/rename/RnTypes.lhs2
-rw-r--r--compiler/typecheck/TcExpr.lhs26
-rw-r--r--compiler/typecheck/TcHsSyn.lhs28
-rw-r--r--compiler/typecheck/TcRnDriver.lhs11
-rw-r--r--compiler/typecheck/TcRnTypes.lhs30
-rw-r--r--compiler/typecheck/TcSplice.lhs418
-rw-r--r--compiler/typecheck/TcSplice.lhs-boot15
20 files changed, 430 insertions, 625 deletions
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 889155c79e..e3e2bfc915 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -571,9 +571,10 @@ addTickHsExpr (HsCoreAnn nm e) =
liftM2 HsCoreAnn
(return nm)
(addTickLHsExpr e)
-addTickHsExpr e@(HsBracket {}) = return e
-addTickHsExpr e@(HsBracketOut {}) = return e
-addTickHsExpr e@(HsSpliceE {}) = return e
+addTickHsExpr e@(HsBracket {}) = return e
+addTickHsExpr e@(HsTcBracketOut {}) = return e
+addTickHsExpr e@(HsRnBracketOut {}) = return e
+addTickHsExpr e@(HsSpliceE {}) = return e
addTickHsExpr (HsProc pat cmdtop) =
liftM2 HsProc
(addTickLPat pat)
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 9ede48f4f8..2c8c490531 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -559,11 +559,11 @@ Here is where we desugar the Template Haskell brackets and escapes
dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
#ifdef GHCI
-dsExpr (HsBracketOut x ps) = dsBracket x ps
+dsExpr (HsTcBracketOut x ps) = dsBracket x ps
#else
-dsExpr (HsBracketOut _ _) = panic "dsExpr HsBracketOut"
+dsExpr (HsTcBracketOut _ _) = panic "dsExpr HsBracketOut"
#endif
-dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
+dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
-- Arrow notation extension
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 6bdcd2fbb7..578b668260 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -67,7 +67,7 @@ import Control.Monad
import Data.List
-----------------------------------------------------------------------------
-dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
+dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr
-- Returns a CoreExpr of type TH.ExpQ
-- The quoted thing is parameterised over Name, even though it has
-- been type checked. We don't want all those type decorations!
@@ -75,7 +75,7 @@ dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
dsBracket brack splices
= dsExtendMetaEnv new_bit (do_brack brack)
where
- new_bit = mkNameEnv [(n, Splice (unLoc e)) | PendingTcSplice n e <- splices]
+ new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n, e) <- splices]
do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
@@ -835,7 +835,7 @@ repTy (HsKindSig t k) = do
t1 <- repLTy t
k1 <- repLKind k
repTSig t1 k1
-repTy (HsSpliceTy splice _ _) = repSplice splice
+repTy (HsSpliceTy splice _) = repSplice splice
repTy (HsExplicitListTy _ tys) = do
tys1 <- repLTys tys
repTPromotedList tys1
@@ -903,7 +903,7 @@ repRole (L _ Nothing) = rep2 inferRName []
repSplice :: HsSplice Name -> DsM (Core a)
-- See Note [How brackets and nested splices are handled] in TcSplice
-- We return a CoreExpr of any old type; the context should know
-repSplice (HsSplice _ n _)
+repSplice (HsSplice n _)
= do { mb_val <- dsLookupMetaEnv n
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
@@ -1026,13 +1026,13 @@ repE (ArithSeq _ _ aseq) =
ds3 <- repLE e3
repFromThenTo ds1 ds2 ds3
-repE (HsSpliceE splice) = repSplice splice
-repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
-repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
-repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
-repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
-repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
-repE e = notHandled "Expression form" (ppr e)
+repE (HsSpliceE _ splice) = repSplice splice
+repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
+repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
+repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
+repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
+repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)
+repE e = notHandled "Expression form" (ppr e)
-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt,
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 4d6939219b..bae804eb07 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -67,7 +67,7 @@ module HsDecls (
) where
-- friends:
-import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr )
+import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, pprUntypedSplice )
-- Because Expr imports Decls via HsBracket
import HsBinds
@@ -290,7 +290,7 @@ data SpliceDecl id
deriving (Data, Typeable)
instance OutputableBndr name => Outputable (SpliceDecl name) where
- ppr (SpliceDecl e _) = ppr e
+ ppr (SpliceDecl (L _ e) _) = pprUntypedSplice e
\end{code}
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index bb0f2d9bcb..61c41da6f0 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -246,20 +246,20 @@ data HsExpr id
| HsBracket (HsBracket id)
- -- See Note [Pending Renamer Splices]
- | HsRnBracketOut (HsBracket Name) -- Output of the renamer is
- -- the *original*
- [PendingSplice] -- renamed expression, plus
- -- _renamed_ splices to be
- -- type checked
+ -- See Note [Pending Splices]
+ | HsRnBracketOut
+ (HsBracket Name) -- Output of the renamer is the *original* renamed
+ -- expression, plus
+ [PendingRnSplice] -- _renamed_ splices to be type checked
- | HsBracketOut (HsBracket Name) -- Output of the type checker is
- -- the *original*
- [PendingSplice] -- renamed expression, plus
- -- _typechecked_ splices to be
- -- pasted back in by the desugarer
+ | HsTcBracketOut
+ (HsBracket Name) -- Output of the type checker is the *original*
+ -- renamed expression, plus
+ [PendingTcSplice] -- _typechecked_ splices to be
+ -- pasted back in by the desugarer
- | HsSpliceE (HsSplice id)
+ | HsSpliceE Bool -- True <=> typed splice
+ (HsSplice id) -- False <=> untyped
| HsQuasiQuoteE (HsQuasiQuote id)
-- See Note [Quasi-quote overview] in TcSplice
@@ -346,14 +346,15 @@ tupArgPresent (Present {}) = True
tupArgPresent (Missing {}) = False
-- See Note [Pending Splices]
-data PendingSplice
- = PendingRnExpSplice Name (LHsExpr Name)
- | PendingRnPatSplice Name (LHsExpr Name)
- | PendingRnTypeSplice Name (LHsExpr Name)
- | PendingRnDeclSplice Name (LHsExpr Name)
+data PendingRnSplice
+ = PendingRnExpSplice (HsSplice Name)
+ | PendingRnPatSplice (HsSplice Name)
+ | PendingRnTypeSplice (HsSplice Name)
+ | PendingRnDeclSplice (HsSplice Name)
| PendingRnCrossStageSplice Name
- | PendingTcSplice Name (LHsExpr Id)
deriving (Data, Typeable)
+
+type PendingTcSplice = (Name, LHsExpr Id)
\end{code}
Note [Pending Splices]
@@ -598,12 +599,12 @@ ppr_expr (HsSCC lbl expr)
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
ppr_expr (HsType id) = ppr id
-ppr_expr (HsSpliceE s) = pprSplice s
-ppr_expr (HsBracket b) = pprHsBracket b
+ppr_expr (HsSpliceE t s) = pprSplice t s
+ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsRnBracketOut e []) = ppr e
ppr_expr (HsRnBracketOut e ps) = ppr e $$ ptext (sLit "pending(rn)") <+> ppr ps
-ppr_expr (HsBracketOut e []) = ppr e
-ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending(tc)") <+> ppr ps
+ppr_expr (HsTcBracketOut e []) = ppr e
+ppr_expr (HsTcBracketOut e ps) = ppr e $$ ptext (sLit "pending(tc)") <+> ppr ps
ppr_expr (HsQuasiQuoteE qq) = ppr qq
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
@@ -687,7 +688,7 @@ hsExprNeedsParens (ExplicitPArr {}) = False
hsExprNeedsParens (HsPar {}) = False
hsExprNeedsParens (HsBracket {}) = False
hsExprNeedsParens (HsRnBracketOut {}) = False
-hsExprNeedsParens (HsBracketOut _ []) = False
+hsExprNeedsParens (HsTcBracketOut {}) = False
hsExprNeedsParens (HsDo sc _ _)
| isListCompExpr sc = False
hsExprNeedsParens _ = True
@@ -1371,17 +1372,19 @@ pprQuals quals = interpp'SP quals
\begin{code}
data HsSplice id = HsSplice -- $z or $(f 4)
- Bool -- True if typed, False if untyped
id -- The id is just a unique name to
(LHsExpr id) -- identify this splice point
deriving (Data, Typeable)
instance OutputableBndr id => Outputable (HsSplice id) where
- ppr = pprSplice
+ ppr (HsSplice n e) = angleBrackets (ppr n <> comma <+> ppr e)
+
+pprUntypedSplice :: OutputableBndr id => HsSplice id -> SDoc
+pprUntypedSplice = pprSplice False
-pprSplice :: OutputableBndr id => HsSplice id -> SDoc
-pprSplice (HsSplice isTyped n e)
- = (if isTyped then ptext (sLit "$$") else char '$')
+pprSplice :: OutputableBndr id => Bool -> HsSplice id -> SDoc
+pprSplice is_typed (HsSplice n e)
+ = (if is_typed then ptext (sLit "$$") else char '$')
<> ifPprDebug (brackets (ppr n)) <> eDoc
where
-- We use pprLExpr to match pprParendExpr:
@@ -1428,13 +1431,12 @@ thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
thTyBrackets :: SDoc -> SDoc
thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]")
-instance Outputable PendingSplice where
- ppr (PendingRnExpSplice name expr) = ppr (name, expr)
- ppr (PendingRnPatSplice name expr) = ppr (name, expr)
- ppr (PendingRnTypeSplice name expr) = ppr (name, expr)
- ppr (PendingRnDeclSplice name expr) = ppr (name, expr)
+instance Outputable PendingRnSplice where
+ ppr (PendingRnExpSplice s) = ppr s
+ ppr (PendingRnPatSplice s) = ppr s
+ ppr (PendingRnTypeSplice s) = ppr s
+ ppr (PendingRnDeclSplice s) = ppr s
ppr (PendingRnCrossStageSplice name) = ppr name
- ppr (PendingTcSplice name expr) = ppr (name, expr)
\end{code}
%************************************************************************
diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot
index a2ef6528b8..027fd7e0a0 100644
--- a/compiler/hsSyn/HsExpr.lhs-boot
+++ b/compiler/hsSyn/HsExpr.lhs-boot
@@ -33,7 +33,6 @@ instance Data i => Data (HsCmd i)
instance (Data i, Data body) => Data (MatchGroup i body)
instance (Data i, Data body) => Data (GRHSs i body)
-instance OutputableBndr id => Outputable (HsSplice id)
instance OutputableBndr id => Outputable (HsExpr id)
instance OutputableBndr id => Outputable (HsCmd id)
@@ -46,8 +45,8 @@ pprLExpr :: (OutputableBndr i) =>
pprExpr :: (OutputableBndr i) =>
HsExpr i -> SDoc
-pprSplice :: (OutputableBndr i) =>
- HsSplice i -> SDoc
+pprUntypedSplice :: (OutputableBndr i) =>
+ HsSplice i -> SDoc
pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body)
=> LPat bndr -> GRHSs id body -> SDoc
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 463d55e0ff..bf44505514 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -23,7 +23,7 @@ module HsPat (
pprParendLPat
) where
-import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr)
+import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprUntypedSplice)
-- friends:
import HsBinds
@@ -271,7 +271,7 @@ pprPat (LitPat s) = ppr s
pprPat (NPat l Nothing _) = ppr l
pprPat (NPat l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
-pprPat (SplicePat splice) = ppr splice
+pprPat (SplicePat splice) = pprUntypedSplice splice
pprPat (QuasiQuotePat qq) = ppr qq
pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index dc442506c6..dfc5817a7d 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -38,11 +38,10 @@ module HsTypes (
pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
) where
-import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
+import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice )
import HsLit
-import NameSet( FreeVars )
import Name( Name )
import RdrName( RdrName )
import DataCon( HsBang(..) )
@@ -230,7 +229,6 @@ data HsType name
| HsQuasiQuoteTy (HsQuasiQuote name)
| HsSpliceTy (HsSplice name)
- FreeVars -- Variables free in the splice (filled in by renamer)
PostTcKind
| HsDocTy (LHsType name) LHsDocString -- A documented type
@@ -634,7 +632,7 @@ ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcol
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
-ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
+ppr_mono_ty _ (HsSpliceTy s _) = pprUntypedSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index fada34e02f..dd77ac15cf 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -55,7 +55,8 @@ module HsUtils(
emptyRecStmt, mkRecStmt,
-- Template Haskell
- unqualSplice, mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkHsQuasiQuote, unqualQuasiQuote,
+ mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkHsSplice,
+ mkHsQuasiQuote, unqualQuasiQuote,
-- Flags
noRebindableInfo,
@@ -251,17 +252,17 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
-mkHsSplice :: Bool -> LHsExpr RdrName -> HsSplice RdrName
-mkHsSplice isTyped e = HsSplice isTyped unqualSplice e
+mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
+mkHsSplice e = HsSplice unqualSplice e
mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
-mkHsSpliceE e = HsSpliceE (mkHsSplice False e)
+mkHsSpliceE e = HsSpliceE False (mkHsSplice e)
mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
-mkHsSpliceTE e = HsSpliceE (mkHsSplice True e)
+mkHsSpliceTE e = HsSpliceE True (mkHsSplice e)
mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
-mkHsSpliceTy e = HsSpliceTy (mkHsSplice False e) emptyFVs placeHolderKind
+mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) placeHolderKind
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 46a694b42b..79e53b26ae 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -1,4 +1,4 @@
-%
+o%
% (c) The University of Glasgow, 1996-2003
Functions over HsSyn specialised to RdrName.
@@ -235,11 +235,13 @@ mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
-- but if she wrote, say,
-- f x then behave as if she'd written $(f x)
-- ie a SpliceD
-mkSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq
-mkSpliceDecl (L loc (HsSpliceE splice)) = SpliceD (SpliceDecl (L loc splice) Explicit)
-mkSpliceDecl other_expr = SpliceD (SpliceDecl (L (getLoc other_expr) splice) Implicit)
+mkSpliceDecl lexpr@(L loc expr)
+ | HsQuasiQuoteE qq <- expr = QuasiQuoteD qq
+ | HsSpliceE is_typed splice <- expr = ASSERT( not is_typed )
+ SpliceD (SpliceDecl (L loc splice) Explicit)
+ | otherwise = SpliceD (SpliceDecl (L loc splice) Implicit)
where
- HsSpliceE splice = mkHsSpliceE other_expr
+ splice = mkHsSplice lexpr
mkTyLit :: Located (HsTyLit) -> P (LHsType RdrName)
mkTyLit l =
@@ -675,11 +677,12 @@ checkAPat msg loc e0 = do
| otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
RecordCon c _ (HsRecFields fs dd)
- -> do fs <- mapM (checkPatField msg) fs
- return (ConPatIn c (RecCon (HsRecFields fs dd)))
- HsSpliceE s -> return (SplicePat s)
- HsQuasiQuoteE q -> return (QuasiQuotePat q)
- _ -> patFail msg loc e0
+ -> do fs <- mapM (checkPatField msg) fs
+ return (ConPatIn c (RecCon (HsRecFields fs dd)))
+ HsSpliceE is_typed s | not is_typed
+ -> return (SplicePat s)
+ HsQuasiQuoteE q -> return (QuasiQuotePat q)
+ _ -> patFail msg loc e0
placeHolderPunRhs :: LHsExpr RdrName
-- The RHS of a punned record field will be filled in by the renamer
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 2365d2613e..3b6361881b 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -24,7 +24,7 @@ import HsSyn
import TcRnMonad
import Module ( getModule )
import RnEnv
-import RnSplice
+import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName )
import RnTypes
import RnPat
import DynFlags
@@ -174,7 +174,7 @@ rnExpr (NegApp e _)
-- (not with an rnExpr crash) in a stage-1 compiler.
rnExpr e@(HsBracket br_body) = rnBracket e br_body
-rnExpr (HsSpliceE splice) = rnSpliceExpr splice
+rnExpr (HsSpliceE is_typed splice) = rnSpliceExpr is_typed splice
rnExpr (HsQuasiQuoteE qq)
diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs
index fc0c499157..a578ef8d10 100644
--- a/compiler/rename/RnSplice.lhs
+++ b/compiler/rename/RnSplice.lhs
@@ -1,7 +1,8 @@
\begin{code}
module RnSplice (
- rnSplice, rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
- rnBracket, checkTH,
+ rnTopSpliceDecls,
+ rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
+ rnBracket,
checkThLocalName
) where
@@ -15,13 +16,13 @@ import TcRnMonad
#ifdef GHCI
import Control.Monad ( unless, when )
import DynFlags
-import DsMeta ( expQTyConName, patQTyConName, typeQTyConName )
+import DsMeta ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName )
import LoadIface ( loadInterfaceForName )
import Module
import RnEnv
-import RnPat
+import RnPat ( rnPat )
import RnSource ( rnSrcDecls, findSplice )
-import RnTypes
+import RnTypes ( rnLHsType )
import SrcLoc
import TcEnv ( checkWellStaged, tcMetaTy )
import Outputable
@@ -30,7 +31,7 @@ import FastString
import {-# SOURCE #-} RnExpr ( rnLExpr )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
-import {-# SOURCE #-} TcSplice ( runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
+import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
#endif
\end{code}
@@ -39,14 +40,14 @@ import {-# SOURCE #-} TcSplice ( runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
rnBracket e _ = failTH e "Template Haskell bracket"
-rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
-rnSplice e = failTH e "Template Haskell splice"
+rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
+rnTopSpliceDecls e = failTH e "Template Haskell top splice"
rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
rnSpliceType e _ = failTH e "Template Haskell type splice"
-rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
-rnSpliceExpr e = failTH e "Template Haskell splice"
+rnSpliceExpr :: Bool -> HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
+rnSpliceExpr _ e = failTH e "Template Haskell splice"
rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars)
rnSplicePat e = failTH e "Template Haskell pattern splice"
@@ -82,210 +83,162 @@ thereby get some bogus unused-import warnings, but we won't crash the
type checker. Not very satisfactory really.
\begin{code}
+rnSpliceGen :: Bool -- Typed splice?
+ -> (HsSplice Name -> RnM (a, FreeVars)) -- Outside brackets, run splice
+ -> (HsSplice Name -> (PendingRnSplice, a)) -- Inside brackets, make it pending
+ -> HsSplice RdrName
+ -> RnM (a, FreeVars)
+rnSpliceGen is_typed_splice run_splice pend_splice splice@(HsSplice _ expr)
+ = addErrCtxt (spliceCtxt (HsSpliceE is_typed_splice splice)) $
+ setSrcSpan (getLoc expr) $ do
+ { stage <- getStage
+ ; case stage of
+ Brack pop_stage RnPendingTyped
+ -> do { checkTc is_typed_splice illegalUntypedSplice
+ ; (splice', fvs) <- setStage pop_stage $
+ rnSplice splice
+ ; let (_pending_splice, result) = pend_splice splice'
+ ; return (result, fvs) }
+
+ Brack pop_stage (RnPendingUntyped ps_var)
+ -> do { checkTc (not is_typed_splice) illegalTypedSplice
+ ; (splice', fvs) <- setStage pop_stage $
+ rnSplice splice
+ ; let (pending_splice, result) = pend_splice splice'
+ ; ps <- readMutVar ps_var
+ ; writeMutVar ps_var (pending_splice : ps)
+ ; return (result, fvs) }
+
+ _ -> do { (splice', fvs1) <- setStage (Splice is_typed_splice) $
+ rnSplice splice
+
+ ; (result, fvs2) <- run_splice splice'
+ ; return (result, fvs1 `plusFV` fvs2) } }
+
+---------------------
rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
-- Not exported...used for all
-rnSplice (HsSplice isTyped n expr)
+rnSplice (HsSplice n expr)
= do { checkTH expr "Template Haskell splice"
; loc <- getSrcSpanM
; n' <- newLocalBndrRn (L loc n)
; (expr', fvs) <- rnLExpr expr
+ ; return (HsSplice n' expr', fvs) }
- ; if isTyped
- then do
- { -- Ugh! See Note [Splices] above
- lcl_rdr <- getLocalRdrEnv
- ; gbl_rdr <- getGlobalRdrEnv
- ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
- isLocalGRE gre]
- lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
-
- ; return (HsSplice isTyped n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names)
- }
- else return (HsSplice isTyped n' expr', fvs)
- }
-\end{code}
-\begin{code}
-rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
-rnSpliceType splice@(HsSplice isTypedSplice _ expr) k
- = setSrcSpan (getLoc expr) $ do
- { stage <- getStage
- ; case stage of
- { Brack isTypedBrack pop_stage ps_var _ ->
- do { when (isTypedBrack && not isTypedSplice) $
- failWithTc illegalUntypedSplice
- ; when (not isTypedBrack && isTypedSplice) $
- failWithTc illegalTypedSplice
-
- -- ToDo: deal with fvs
- ; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $
- rnSplice splice
-
- ; ps <- readMutVar ps_var
- ; writeMutVar ps_var (PendingRnTypeSplice name expr' : ps)
-
- ; return (HsSpliceTy splice' fvs k, fvs)
- }
- ; _ ->
- do { -- ToDo: deal with fvs
- (splice', fvs) <- addErrCtxt (spliceResultDoc expr) $
- setStage (Splice isTypedSplice) $
- rnSplice splice
- ; maybeExpandTopSplice splice' fvs
- }
- }
- }
+---------------------
+rnSpliceExpr :: Bool -> HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
+rnSpliceExpr is_typed splice
+ = rnSpliceGen is_typed run_expr_splice pend_expr_splice splice
where
- maybeExpandTopSplice :: HsSplice Name -> FreeVars -> RnM (HsType Name, FreeVars)
- maybeExpandTopSplice splice@(HsSplice True _ _) fvs
- = return (HsSpliceTy splice fvs k, fvs)
+ pend_expr_splice :: HsSplice Name -> (PendingRnSplice, HsExpr Name)
+ pend_expr_splice rn_splice
+ = (PendingRnExpSplice rn_splice, HsSpliceE is_typed rn_splice)
+
+ run_expr_splice :: HsSplice Name -> RnM (HsExpr Name, FreeVars)
+ run_expr_splice rn_splice@(HsSplice _ expr)
+ | is_typed -- Run it later, in the type checker
+ = do { -- Ugh! See Note [Splices] above
+ lcl_rdr <- getLocalRdrEnv
+ ; gbl_rdr <- getGlobalRdrEnv
+ ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr
+ , isLocalGRE gre]
+ lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
- maybeExpandTopSplice (HsSplice False _ expr) _
- = do { -- The splice must have type TypeQ
- ; meta_exp_ty <- tcMetaTy typeQTyConName
+ ; return (HsSpliceE is_typed rn_splice, lcl_names `plusFV` gbl_names) }
+
+ | otherwise -- Run it here
+ = do { -- The splice must have type ExpQ
+ ; meta_exp_ty <- tcMetaTy expQTyConName
-- Typecheck the expression
; zonked_q_expr <- tcTopSpliceExpr False $
tcMonoExpr expr meta_exp_ty
-- Run the expression
- ; hs_ty2 <- runMetaT zonked_q_expr
- ; showSplice "type" expr (ppr hs_ty2)
-
- ; (hs_ty3, fvs) <- addErrCtxt (spliceResultDoc expr) $
- do { let doc = SpliceTypeCtx hs_ty2
- ; checkNoErrs $ rnLHsType doc hs_ty2
- -- checkNoErrs: see Note [Renamer errors]
- }
- ; return (unLoc hs_ty3, fvs)
- }
-\end{code}
+ ; expr2 <- runMetaE zonked_q_expr
+ ; showSplice "expression" expr (ppr expr2)
-\begin{code}
-rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
-rnSpliceExpr splice@(HsSplice isTypedSplice _ expr)
- = addErrCtxt (exprCtxt (HsSpliceE splice)) $
- setSrcSpan (getLoc expr) $ do
- { stage <- getStage
- ; case stage of
- { Brack isTypedBrack pop_stage ps_var _ ->
- do { when (isTypedBrack && not isTypedSplice) $
- failWithTc illegalUntypedSplice
- ; when (not isTypedBrack && isTypedSplice) $
- failWithTc illegalTypedSplice
-
- ; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $
- rnSplice splice
-
- ; ps <- readMutVar ps_var
- ; writeMutVar ps_var (PendingRnExpSplice name expr' : ps)
-
- ; return (HsSpliceE splice', fvs)
- }
- ; _ ->
- do { (splice', fvs) <- addErrCtxt (spliceResultDoc expr) $
- setStage (Splice isTypedSplice) $
- rnSplice splice
- ; maybeExpandTopSplice splice' fvs
- }
- }
- }
+ ; (lexpr3, fvs) <- checkNoErrs $
+ rnLExpr expr2
+ ; return (unLoc lexpr3, fvs) }
+
+----------------------
+rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
+rnSpliceType splice k
+ = rnSpliceGen False run_type_splice pend_type_splice splice
where
- maybeExpandTopSplice :: HsSplice Name -> FreeVars -> RnM (HsExpr Name, FreeVars)
- maybeExpandTopSplice splice@(HsSplice True _ _) fvs
- = return (HsSpliceE splice, fvs)
+ pend_type_splice rn_splice
+ = (PendingRnTypeSplice rn_splice, HsSpliceTy rn_splice k)
- maybeExpandTopSplice (HsSplice False _ expr) _
- = do { -- The splice must have type ExpQ
- ; meta_exp_ty <- tcMetaTy expQTyConName
+ run_type_splice (HsSplice _ expr)
+ = do { meta_exp_ty <- tcMetaTy typeQTyConName
+
+ -- Typecheck the expression
+ ; zonked_q_expr <- tcTopSpliceExpr False $
+ tcMonoExpr expr meta_exp_ty
+
+ -- Run the expression
+ ; hs_ty2 <- runMetaT zonked_q_expr
+ ; showSplice "type" expr (ppr hs_ty2)
+
+ ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
+ ; checkNoErrs $ rnLHsType doc hs_ty2
+ -- checkNoErrs: see Note [Renamer errors]
+ }
+ ; return (unLoc hs_ty3, fvs) }
+
+----------------------
+rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars)
+rnSplicePat splice
+ = rnSpliceGen False run_pat_splice pend_pat_splice splice
+ where
+ pend_pat_splice rn_splice
+ = (PendingRnPatSplice rn_splice, SplicePat rn_splice)
+
+ run_pat_splice (HsSplice _ expr)
+ = do { meta_exp_ty <- tcMetaTy patQTyConName
-- Typecheck the expression
; zonked_q_expr <- tcTopSpliceExpr False $
tcMonoExpr expr meta_exp_ty
-- Run the expression
- ; expr2 <- runMetaE zonked_q_expr
- ; showSplice "expression" expr (ppr expr2)
+ ; pat <- runMetaP zonked_q_expr
+ ; showSplice "pattern" expr (ppr pat)
- ; (lexpr3, fvs) <- addErrCtxt (spliceResultDoc expr) $
- checkNoErrs $
- rnLExpr expr2
- ; return (unLoc lexpr3, fvs)
- }
-\end{code}
+ ; (pat', fvs) <- checkNoErrs $
+ rnPat ThPatSplice pat $ \pat' -> return (pat', emptyFVs)
-\begin{code}
-rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars)
-rnSplicePat (HsSplice True _ _)
- = panic "rnSplicePat: encountered typed pattern splice"
-
-rnSplicePat splice@(HsSplice False _ expr)
- = addErrCtxt (exprCtxt (HsSpliceE splice)) $
- setSrcSpan (getLoc expr) $ do
- { stage <- getStage
- ; case stage of
- { Brack isTypedBrack pop_stage ps_var _ ->
- do { checkTc (not isTypedBrack) illegalUntypedSplice
+ ; return (unLoc pat', fvs) }
- ; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $
- rnSplice splice
+----------------------
+rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)
+rnSpliceDecl (SpliceDecl (L loc splice) flg)
+ = rnSpliceGen False run_decl_splice pend_decl_splice splice
+ where
+ pend_decl_splice rn_splice
+ = (PendingRnDeclSplice rn_splice, SpliceDecl(L loc rn_splice) flg)
- ; ps <- readMutVar ps_var
- ; writeMutVar ps_var (PendingRnPatSplice name expr' : ps)
-
- ; return (SplicePat splice', fvs)
- }
- ; _ ->
- do { (HsSplice _ _ expr', fvs) <- addErrCtxt (spliceResultDoc expr) $
- setStage (Splice False) $
- rnSplice splice
-
- -- The splice must have type Pat
- ; meta_exp_ty <- tcMetaTy patQTyConName
-
- -- Typecheck the expression
- ; zonked_q_expr <- tcTopSpliceExpr False $
- tcMonoExpr expr' meta_exp_ty
-
- -- Run the expression
- ; pat <- runMetaP zonked_q_expr
- ; showSplice "pattern" expr' (ppr pat)
-
- ; (pat', _) <- addErrCtxt (spliceResultDoc expr) $
- checkNoErrs $
- rnPat ThPatSplice pat $ \pat' -> return (pat', emptyFVs)
-
- ; return (unLoc pat', fvs)
- }
- }
- }
+ run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)
\end{code}
\begin{code}
-rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)
-rnSpliceDecl (SpliceDecl (L _ (HsSplice True _ _)) _)
- = panic "rnSpliceDecls: encountered typed declaration splice"
+rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
+-- Declaration splice at the very top level of the module
+rnTopSpliceDecls (HsSplice _ expr)
+ = do { (expr', fvs) <- setStage (Splice False) $
+ rnLExpr expr
-rnSpliceDecl (SpliceDecl (L loc splice@(HsSplice False _ expr)) flg)
- = addErrCtxt (exprCtxt (HsSpliceE splice)) $
- setSrcSpan (getLoc expr) $ do
- { stage <- getStage
- ; case stage of
- { Brack isTypedBrack pop_stage ps_var _ ->
- do { checkTc (not isTypedBrack) illegalUntypedSplice
+ ; list_q <- tcMetaTy decsQTyConName -- Q [Dec]
+ ; zonked_q_expr <- tcTopSpliceExpr False (tcMonoExpr expr' list_q)
- ; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $
- rnSplice splice
+ -- Run the expression
+ ; decls <- runMetaD zonked_q_expr
+ ; showSplice "declarations" expr'
+ (ppr (getLoc expr) $$ (vcat (map ppr decls)))
- ; ps <- readMutVar ps_var
- ; writeMutVar ps_var (PendingRnDeclSplice name expr' : ps)
-
- ; return (SpliceDecl (L loc splice') flg, fvs)
- }
- ; _ ->
- pprPanic "rnSpliceDecls: should not have been called on top-level splice" (ppr expr)
- }
- }
+ ; return (decls,fvs) }
\end{code}
%************************************************************************
@@ -317,16 +270,16 @@ rnBracket e br_body
-- Brackets are desugared to code that mentions the TH package
; recordThUse
- ; pending_splices <- newMutVar []
- ; let brack_stage = Brack (isTypedBracket br_body)
- cur_stage pending_splices
- (error "rnBracket: don't neet lie")
+ ; case isTypedBracket br_body of
+ True -> do { (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $
+ rn_bracket cur_stage br_body
+ ; return (HsBracket body', fvs_e) }
- ; (body', fvs_e) <- setStage brack_stage $
- rn_bracket cur_stage br_body
- ; pendings <- readMutVar pending_splices
-
- ; return (HsRnBracketOut body' pendings, fvs_e)
+ False -> do { ps_var <- newMutVar []
+ ; (body', fvs_e) <- setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
+ rn_bracket cur_stage br_body
+ ; pendings <- readMutVar ps_var
+ ; return (HsRnBracketOut body' pendings, fvs_e) }
}
rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
@@ -405,9 +358,8 @@ rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e
\end{code}
\begin{code}
-exprCtxt :: HsExpr RdrName -> SDoc
-exprCtxt expr
- = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
+spliceCtxt :: HsExpr RdrName -> SDoc
+spliceCtxt expr= hang (ptext (sLit "In the splice:")) 2 (ppr expr)
showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
-- Note that 'before' is *renamed* but not *typechecked*
@@ -447,11 +399,11 @@ quotationCtxtDoc br_body
= hang (ptext (sLit "In the Template Haskell quotation"))
2 (ppr br_body)
-spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc
-spliceResultDoc expr
- = vcat [ hang (ptext (sLit "In the splice:"))
- 2 (char '$' <> pprParendExpr expr)
- , ptext (sLit "To see what the splice expanded to, use -ddump-splices") ]
+-- spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc
+-- spliceResultDoc expr
+-- = vcat [ hang (ptext (sLit "In the splice:"))
+-- 2 (char '$' <> pprParendExpr expr)
+-- , ptext (sLit "To see what the splice expanded to, use -ddump-splices") ]
#endif
\end{code}
@@ -483,10 +435,7 @@ checkCrossStageLifting :: TopLevelFlag -> Name -> ThStage -> TcM ()
-- Examples \x -> [| x |]
-- [| map |]
-checkCrossStageLifting _ _ Comp = return ()
-checkCrossStageLifting _ _ (Splice _) = return ()
-
-checkCrossStageLifting top_lvl name (Brack _ _ ps_var _)
+checkCrossStageLifting top_lvl name (Brack _ (RnPendingUntyped ps_var))
| isTopLevel top_lvl
-- Top-level identifiers in this module,
-- (which have External Names)
@@ -511,8 +460,9 @@ checkCrossStageLifting top_lvl name (Brack _ _ ps_var _)
do { traceRn (text "checkCrossStageLifting" <+> ppr name)
; -- Update the pending splices
; ps <- readMutVar ps_var
- ; writeMutVar ps_var (PendingRnCrossStageSplice name : ps)
- }
+ ; writeMutVar ps_var (PendingRnCrossStageSplice name : ps) }
+
+checkCrossStageLifting _ _ _ = return ()
#endif /* GHCI */
\end{code}
diff --git a/compiler/rename/RnSplice.lhs-boot b/compiler/rename/RnSplice.lhs-boot
index 25d5cc949d..5f417ae7fc 100644
--- a/compiler/rename/RnSplice.lhs-boot
+++ b/compiler/rename/RnSplice.lhs-boot
@@ -7,10 +7,7 @@ import RdrName
import Name
import NameSet
-rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
-
-rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
-rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
-rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars)
+rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
+rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars)
rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)
\end{code}
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 0052393bb4..23c54c3bed 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -249,7 +249,7 @@ rnHsTyKi isType doc (HsEqTy ty1 ty2)
; (ty2', fvs2) <- rnLHsType doc ty2
; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
-rnHsTyKi isType _ (HsSpliceTy sp _ k)
+rnHsTyKi isType _ (HsSpliceTy sp k)
= ASSERT( isType )
rnSpliceType sp k
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 6f3eb41ffd..2c462970bb 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -1,4 +1,4 @@
-%
+c%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
@@ -12,7 +12,7 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
#include "HsVersions.h"
-import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
+import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
#ifdef GHCI
import DsMeta( liftStringName, liftName )
#endif
@@ -797,13 +797,9 @@ tcExpr (PArrSeq _ _) _
%************************************************************************
\begin{code}
- -- Rename excludes these cases otherwise
-tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
-tcExpr (HsRnBracketOut brack ps) res_ty = tcBracket brack ps res_ty
-tcExpr e@(HsBracketOut _ _) _ =
- pprPanic "Should never see HsBracketOut in type checker" (ppr e)
-tcExpr e@(HsQuasiQuoteE _) _ =
- pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
+tcExpr (HsSpliceE is_ty splice) res_ty = tcSpliceExpr is_ty splice res_ty
+tcExpr (HsBracket brack) res_ty = tcTypedBracket brack res_ty
+tcExpr (HsRnBracketOut brack ps) res_ty = tcUntypedBracket brack ps res_ty
\end{code}
@@ -816,6 +812,7 @@ tcExpr e@(HsQuasiQuoteE _) _ =
\begin{code}
tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
-- Include ArrForm, ArrApp, which shouldn't appear at all
+ -- Also HsTcBracketOut, HsQuasiQuoteE
\end{code}
@@ -1290,10 +1287,7 @@ checkCrossStageLifting :: Id -> ThStage -> TcM ()
-- [| map |]
-- There is no error-checking to do, because the renamer did that
-checkCrossStageLifting _ Comp = return ()
-checkCrossStageLifting _ (Splice _) = return ()
-
-checkCrossStageLifting id (Brack _ _ ps_var lie_var)
+checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
= -- Nested identifiers, such as 'x' in
-- E.g. \x -> [| h x |]
-- We must behave as if the reference to x was
@@ -1316,17 +1310,19 @@ checkCrossStageLifting id (Brack _ _ ps_var lie_var)
-- See Note [Lifting strings]
; return (HsVar sid) }
else
- setConstraintVar lie_var $ do
+ setConstraintVar lie_var $
-- Put the 'lift' constraint into the right LIE
newMethodFromName (OccurrenceOf (idName id))
DsMeta.liftName id_ty
-- Update the pending splices
; ps <- readMutVar ps_var
- ; writeMutVar ps_var (PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id)) : ps)
+ ; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps)
; return () }
+checkCrossStageLifting _ _ = return ()
+
polySpliceErr :: Id -> SDoc
polySpliceErr id
= ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 691a9ab496..8b136f56e2 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -556,31 +556,15 @@ zonkExpr env (HsApp e1 e2)
zonkExpr _ e@(HsRnBracketOut _ _)
= pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
-zonkExpr env (HsBracketOut body bs)
+zonkExpr env (HsTcBracketOut body bs)
= do bs' <- mapM zonk_b bs
- return (HsBracketOut body bs')
+ return (HsTcBracketOut body bs')
where
- zonk_b (PendingRnExpSplice _ e)
- = pprPanic "zonkExpr: PendingRnExpSplice" (ppr e)
+ zonk_b (n, e) = do e' <- zonkLExpr env e
+ return (n, e')
- zonk_b (PendingRnPatSplice _ e)
- = pprPanic "zonkExpr: PendingRnPatSplice" (ppr e)
-
- zonk_b (PendingRnCrossStageSplice n)
- = pprPanic "zonkExpr: PendingRnCrossStageSplice" (ppr n)
-
- zonk_b (PendingRnTypeSplice _ e)
- = pprPanic "zonkExpr: PendingRnTypeSplice" (ppr e)
-
- zonk_b (PendingRnDeclSplice _ e)
- = pprPanic "zonkExpr: PendingRnDeclSplice" (ppr e)
-
- zonk_b (PendingTcSplice n e)
- = do e' <- zonkLExpr env e
- return (PendingTcSplice n e')
-
-zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
- return (HsSpliceE s)
+zonkExpr _ (HsSpliceE t s) = WARN( True, ppr s ) -- Should not happen
+ return (HsSpliceE t s)
zonkExpr env (OpApp e1 op fixity e2)
= do new_e1 <- zonkLExpr env e1
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 73f78b793c..0926b49259 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -22,8 +22,8 @@ module TcRnDriver (
) where
#ifdef GHCI
-import {-# SOURCE #-} TcSplice ( tcSpliceDecls, runQuasi )
-import RnSplice ( rnSplice )
+import {-# SOURCE #-} TcSplice ( runQuasi )
+import RnSplice ( rnTopSpliceDecls )
#endif
import DynFlags
@@ -546,12 +546,7 @@ tc_rn_src_decls boot_details ds
-- If there's a splice, we must carry on
; Just (SpliceDecl (L _ splice) _, rest_ds) ->
do { -- Rename the splice expression, and get its supporting decls
- (rn_splice, splice_fvs) <- checkNoErrs (rnSplice splice)
- -- checkNoErrs: don't typecheck if renaming failed
- ; rnDump (ppr rn_splice)
-
- -- Execute the splice
- ; spliced_decls <- tcSpliceDecls rn_splice
+ (spliced_decls, splice_fvs) <- checkNoErrs (rnTopSpliceDecls splice)
-- Glue them on the front of the remaining decls and loop
; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 57112d35ff..e16bf569f4 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -35,7 +35,7 @@ module TcRnTypes(
pprTcTyThingCategory, pprPECategory,
-- Template Haskell
- ThStage(..), topStage, topAnnStage, topSpliceStage,
+ ThStage(..), PendingStuff(..), topStage, topAnnStage, topSpliceStage,
ThLevel, impLevel, outerLevel, thLevel,
-- Arrows
@@ -536,10 +536,18 @@ data ThStage -- See Note [Template Haskell state diagram] in TcSplice
-- Binding level = 1
| Brack -- Inside brackets
- Bool -- True if inside a typed bracket, False otherwise
- ThStage -- Binding level = level(stage) + 1
- (TcRef [PendingSplice]) -- Accumulate pending splices here
- (TcRef WantedConstraints) -- and type constraints here
+ ThStage -- Enclosing stage
+ PendingStuff
+
+data PendingStuff
+ = RnPendingUntyped -- Renaming the inside of an *untyped* bracket
+ (TcRef [PendingRnSplice]) -- Pending splices in here
+
+ | RnPendingTyped -- Renaming the inside of a *typed* bracket
+
+ | TcPending -- Typechecking the iniside of a typed bracket
+ (TcRef [PendingTcSplice]) -- Accumulate pending splices here
+ (TcRef WantedConstraints) -- and type constraints here
topStage, topAnnStage, topSpliceStage :: ThStage
topStage = Comp
@@ -547,9 +555,9 @@ topAnnStage = Splice False
topSpliceStage = Splice False
instance Outputable ThStage where
- ppr (Splice _) = text "Splice"
- ppr Comp = text "Comp"
- ppr (Brack _ s _ _) = text "Brack" <> parens (ppr s)
+ ppr (Splice _) = text "Splice"
+ ppr Comp = text "Comp"
+ ppr (Brack s _) = text "Brack" <> parens (ppr s)
type ThLevel = Int
-- NB: see Note [Template Haskell levels] in TcSplice
@@ -563,9 +571,9 @@ impLevel = 0 -- Imported things; they can be used inside a top level splice
outerLevel = 1 -- Things defined outside brackets
thLevel :: ThStage -> ThLevel
-thLevel (Splice _) = 0
-thLevel Comp = 1
-thLevel (Brack _ s _ _) = thLevel s + 1
+thLevel (Splice _) = 0
+thLevel Comp = 1
+thLevel (Brack s _) = thLevel s + 1
---------------------------
-- Arrow-notation context
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 29fae0e1b5..2277871daf 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -12,7 +12,7 @@ TcSplice: Template Haskell splices
module TcSplice(
-- These functions are defined in stage1 and stage2
-- The raise civilised errors in stage1
- tcSpliceExpr, tcSpliceDecls, tcBracket,
+ tcSpliceExpr, tcSpliceDecls, tcTypedBracket, tcUntypedBracket,
runQuasiQuoteExpr, runQuasiQuotePat,
runQuasiQuoteDecl, runQuasiQuoteType,
runAnnotation,
@@ -114,9 +114,10 @@ import GHC.Exts ( unsafeCoerce# )
%************************************************************************
\begin{code}
-tcBracket :: HsBracket Name -> [PendingSplice] -> TcRhoType -> TcM (HsExpr TcId)
-tcSpliceDecls :: HsSplice Name -> TcM [LHsDecl RdrName]
-tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
+tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
+tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId)
+tcSpliceDecls :: HsSplice Name -> TcM [LHsDecl RdrName]
+tcSpliceExpr :: Bool -> HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
-- None of these functions add constraints to the LIE
runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
@@ -127,8 +128,9 @@ runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
#ifndef GHCI
-tcBracket x _ _ = failTH x "Template Haskell bracket"
-tcSpliceExpr e _ = failTH e "Template Haskell splice"
+tcTypedBracket x _ = failTH x "Template Haskell bracket"
+tcUntypedBracket x _ _ = failTH x "Template Haskell bracket"
+tcSpliceExpr _ e _ = failTH e "Template Haskell splice"
tcSpliceDecls x = failTH x "Template Haskell declaration splice"
runQuasiQuoteExpr q = failTH q "quasiquote"
@@ -162,19 +164,51 @@ very straightforwardly:
Note [How brackets and nested splices are handled]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Nested splices (those inside a [| .. |] quotation bracket), are treated
-quite differently.
-
- * After typechecking, the bracket [| |] carries
-
- a) A mutable list of PendingSplice
- type PendingSplice = (Name, LHsExpr Id)
-
- b) The quoted expression e, *renamed*: (HsExpr Name)
- The expression e has been typechecked, but the result of
- that typechecking is discarded.
-
- * The brakcet is desugared by DsMeta.dsBracket. It
+Nested splices (those inside a [| .. |] quotation bracket),
+are treated quite differently.
+
+Remember, there are two forms of bracket
+ typed [|| e ||]
+ and untyped [| e |]
+
+The life cycle of a typed bracket:
+ * Starts as HsBracket
+
+ * When renaming:
+ * Set the ThStage to (Brack s RnPendingTyped)
+ * Rename the body
+ * Result is still a HsBracket
+
+ * When typechecking:
+ * Set the ThStage to (Brack s (TcPending ps_var lie_var))
+ * Typecheck the body, and throw away the elaborated result
+ * 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
+
+The life cycle of a un-typed bracket:
+ * Starts as HsBracket
+
+ * 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)
+
+ * When typechecking a HsRnBracketOut
+ * 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
+
+
+In both cases, desugaring happens like this:
+ * HsTcBracketOut is desugared by DsMeta.dsBracket. It
a) Extends the ds_meta environment with the PendingSplices
attached to the bracket
@@ -189,17 +223,6 @@ quite differently.
${n}(e). The name is initialised to an (Unqual "splice") when the
splice is created; the renamer gives it a unique.
- * When the type checker type-checks a nested splice ${n}(e), it
- - typechecks e
- - adds the typechecked expression (of type (HsExpr Id))
- as a pending splice to the enclosing bracket
- - returns something non-committal
- Eg for [| f ${n}(g x) |], the typechecker
- - attaches the typechecked term (g x) to the pending splices for n
- in the outer bracket
- - returns a non-committal type \alpha.
- Remember that the bracket discards the typechecked term altogether
-
* When DsMeta (used to desugar the body of the bracket) comes across
a splice, it looks up the splice's Name, n, in the ds_meta envt,
to find an (HsExpr Id) that should be substituted for the splice;
@@ -307,98 +330,77 @@ When a variable is used, we compare
\begin{code}
-- See Note [How brackets and nested splices are handled]
-tcBracket brack ps res_ty
+-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
+tcTypedBracket brack@(TExpBr expr) res_ty
= addErrCtxt (quotationCtxtDoc brack) $
do { cur_stage <- getStage
- -- Check for nested brackets
- ; case cur_stage of
- { Splice True -> checkTc (isTypedBracket brack) illegalUntypedBracket
- ; Splice False -> checkTc (not (isTypedBracket brack)) illegalTypedBracket
- ; Comp -> return ()
- ; Brack {} -> failWithTc illegalBracket
- }
-
- -- Brackets are desugared to code that mentions the TH package
- ; recordThUse
-
- -- Typecheck expr to make sure it is valid,
- -- but throw away the results. We'll type check
- -- it again when we actually use it.
; ps_ref <- newMutVar []
- ; lie_var <- getConstraintVar
- ; let brack_stage = Brack (isTypedBracket brack) cur_stage ps_ref lie_var
- ; setStage brack_stage $
- tc_bracket brack ps_ref
- }
- where
- tc_bracket :: HsBracket Name -> TcRef [PendingSplice] -> TcM (HsExpr TcId)
- tc_bracket brack ps_ref
- | not (isTypedBracket brack)
- = do { traceTc "tc_bracked untyped" (ppr brack $$ ppr ps)
- ; mapM_ tcPendingSplice ps
- ; meta_ty <- tcUntypedBracket brack
- ; ps' <- readMutVar ps_ref
- ; co <- unifyType meta_ty res_ty
- ; traceTc "tc_bracked done untyped" (ppr meta_ty)
- ; return (mkHsWrapCo co (HsBracketOut brack ps'))
- }
-
- tc_bracket (TExpBr expr) ps_ref
- = do { traceTc "tc_bracked typed" (ppr brack)
- ; any_ty <- newFlexiTyVarTy openTypeKind
- -- NC for no context; tcBracket does that
- ; _ <- tcMonoExprNC expr any_ty
- ; meta_ty <- tcTExpTy any_ty
- ; ps' <- readMutVar ps_ref
- ; co <- unifyType meta_ty res_ty
- ; texpco <- tcLookupId unsafeTExpCoerceName
- ; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [any_ty]) (noLoc (HsBracketOut brack ps')))))
- }
-
- tc_bracket _ _
- = panic "tc_bracket: Expected untyped splice"
-
-tcUntypedBracket :: HsBracket Name -> TcM TcType
-tcUntypedBracket (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
-tcUntypedBracket (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp)
-tcUntypedBracket (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
-tcUntypedBracket (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
-tcUntypedBracket (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)
-tcUntypedBracket (DecBrL _) = panic "tcUntypedBracket: Unexpected DecBrL"
-tcUntypedBracket (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr"
-
-tcPendingSplice :: PendingSplice -> TcM ()
-tcPendingSplice (PendingRnExpSplice n expr)
- = do { res_ty <- newFlexiTyVarTy openTypeKind
- ; _ <- tcSpliceExpr (HsSplice False n expr) res_ty
- ; return ()
- }
-
-tcPendingSplice (PendingRnPatSplice n expr)
- = do { res_ty <- newFlexiTyVarTy openTypeKind
- ; _ <- tcSplicePat (HsSplice False n expr) res_ty
- ; return ()
- }
+ ; lie_var <- getConstraintVar -- Any constraints arising from nested splices
+ -- should get thrown into the constraint set
+ -- from outside the bracket
-tcPendingSplice (PendingRnCrossStageSplice n)
- = do { res_ty <- newFlexiTyVarTy openTypeKind
- ; _ <- tcCheckId n res_ty
- ; return ()
- }
+ -- Typecheck expr to make sure it is valid,
+ -- Throw away the typechecked expression but return its type.
+ -- We'll typecheck it again when we splice it in somewhere
+ ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
+ tcInferRhoNC expr
+ -- NC for no context; tcBracket does that
+
+ ; meta_ty <- tcTExpTy expr_ty
+ ; co <- unifyType meta_ty res_ty
+ ; ps' <- readMutVar ps_ref
+ ; texpco <- tcLookupId unsafeTExpCoerceName
+ ; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
+ (noLoc (HsTcBracketOut brack ps'))))) }
+tcTypedBracket other_brack _
+ = pprPanic "tcTypedBracket" (ppr other_brack)
+
+-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId)
+tcUntypedBracket brack ps res_ty
+ = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
+ ; ps' <- mapM tcPendingSplice ps
+ ; meta_ty <- tcBrackTy brack
+ ; co <- unifyType meta_ty res_ty
+ ; traceTc "tc_bracket done untyped" (ppr meta_ty)
+ ; return (mkHsWrapCo co (HsTcBracketOut brack ps')) }
-tcPendingSplice (PendingRnTypeSplice n expr)
- = do { _ <- tcSpliceType (HsSplice False n expr) emptyFVs
- ; return ()
- }
+---------------
+tcBrackTy :: HsBracket Name -> TcM TcType
+tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
+tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp)
+tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
+tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
+tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)
+tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL"
+tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr"
-tcPendingSplice (PendingRnDeclSplice n expr)
- = do { _ <- tcSpliceDecls (HsSplice False n expr)
- ; return ()
- }
+---------------
+tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
+tcPendingSplice (PendingRnExpSplice (HsSplice n expr))
+ = do { res_ty <- tcMetaTy expQTyConName
+ ; tc_pending_splice n expr res_ty }
+tcPendingSplice (PendingRnPatSplice (HsSplice n expr))
+ = do { res_ty <- tcMetaTy patQTyConName
+ ; tc_pending_splice n expr res_ty }
+tcPendingSplice (PendingRnTypeSplice (HsSplice n expr))
+ = do { res_ty <- tcMetaTy typeQTyConName
+ ; tc_pending_splice n expr res_ty }
+tcPendingSplice (PendingRnDeclSplice (HsSplice n expr))
+ = do { res_ty <- tcMetaTy decsQTyConName
+ ; tc_pending_splice n expr res_ty }
+
+tcPendingSplice (PendingRnCrossStageSplice n)
+ -- Behave like $(lift x); not very pretty
+ = do { res_ty <- tcMetaTy expQTyConName
+ ; tc_pending_splice n (nlHsApp (nlHsVar liftName) (nlHsVar n)) res_ty }
-tcPendingSplice (PendingTcSplice _ expr)
- = pprPanic "tcPendingSplice: PendingTcSplice" (ppr expr)
+---------------
+tc_pending_splice :: Name -> LHsExpr Name -> TcRhoType -> TcM PendingTcSplice
+tc_pending_splice splice_name expr res_ty
+ = do { expr' <- tcMonoExpr expr res_ty
+ ; return (splice_name, expr') }
+---------------
-- Takes a type tau and returns the type Q (TExp tau)
tcTExpTy :: TcType -> TcM TcType
tcTExpTy tau = do
@@ -415,58 +417,35 @@ tcTExpTy tau = do
%************************************************************************
\begin{code}
-tcSpliceExpr splice@(HsSplice isTypedSplice name expr) res_ty
- = addErrCtxt (spliceCtxtDoc splice) $
+tcSpliceExpr is_typed splice@(HsSplice name expr) res_ty
+ = ASSERT2( is_typed, ppr splice )
+ addErrCtxt (spliceCtxtDoc splice) $
setSrcSpan (getLoc expr) $ do
{ stage <- getStage
; case stage of
- { Splice {} | not isTypedSplice -> pprPanic "tcSpliceExpr: encountered unexpanded top-level untyped splice" (ppr splice)
- ; Comp {} | not isTypedSplice -> pprPanic "tcSpliceExpr: encountered unexpanded top-level untyped splice" (ppr splice)
- ; Splice {} -> tcTopSplice expr res_ty
- ; Comp -> tcTopSplice expr res_ty
- ; Brack isTypedBrack pop_stage ps_var lie_var -> do
-
- { when (isTypedBrack && not isTypedSplice) $
- failWithTc illegalUntypedSplice
- ; when (not isTypedBrack && isTypedSplice) $
- failWithTc illegalTypedSplice
-
- ; tc_splice_expr isTypedSplice pop_stage ps_var lie_var
-
- -- The returned expression is ignored
- ; return (panic "tcSpliceExpr")
- }}}
- where
- tc_splice_expr :: Bool
- -> ThStage -> TcRef [PendingSplice] -> TcRef WantedConstraints
- -> TcM ()
+ Splice {} -> tcTopSplice expr res_ty
+ Comp -> tcTopSplice expr res_ty
+ Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty }
+
+tcNestedSplice :: ThStage -> PendingStuff -> Name
+ -> LHsExpr Name -> TcRhoType -> TcM (HsExpr Id)
-- See Note [How brackets and nested splices are handled]
-- A splice inside brackets
- -- NB: ignore res_ty, apart from zapping it to a mono-type
- -- e.g. [| reverse $(h 4) |]
- -- Here (h 4) :: Q Exp
- -- but $(h 4) :: forall a.a i.e. anything!
- tc_splice_expr False pop_stage ps_var lie_var
- = do { meta_exp_ty <- tcMetaTy expQTyConName
- ; expr' <- setStage pop_stage $
- setConstraintVar lie_var $
- tcMonoExpr expr meta_exp_ty
- ; ps <- readMutVar ps_var
- ; writeMutVar ps_var (PendingTcSplice name expr' : ps)
- ; return ()
- }
-
- tc_splice_expr True pop_stage ps_var lie_var
- = do { meta_exp_ty <- tcTExpTy res_ty
- ; expr' <- setStage pop_stage $
- setConstraintVar lie_var $
- tcMonoExpr expr meta_exp_ty
- ; untypeq <- tcLookupId unTypeQName
- ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'
- ; ps <- readMutVar ps_var
- ; writeMutVar ps_var (PendingTcSplice name expr'' : ps)
- ; return ()
- }
+tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty
+ = do { meta_exp_ty <- tcTExpTy res_ty
+ ; expr' <- setStage pop_stage $
+ setConstraintVar lie_var $
+ tcMonoExpr expr meta_exp_ty
+ ; untypeq <- tcLookupId unTypeQName
+ ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'
+ ; ps <- readMutVar ps_var
+ ; writeMutVar ps_var ((splice_name, expr'') : ps)
+
+ -- The returned expression is ignored; it's in the pending splices
+ ; return (panic "tcSpliceExpr") }
+
+tcNestedSplice _ _ splice_name _ _
+ = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)
tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id)
tcTopSplice expr res_ty
@@ -496,31 +475,8 @@ tcTopSplice expr res_ty
%************************************************************************
\begin{code}
-tcSplicePat :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
-tcSplicePat splice@(HsSplice True _ _) _
- = pprPanic "tcSplicePat: encountered typed pattern splice" (ppr splice)
-
-tcSplicePat splice@(HsSplice False name expr) _
- = addErrCtxt (spliceCtxtDoc splice) $
- setSrcSpan (getLoc expr) $ do
- { stage <- getStage
- ; case stage of
- { Splice {} -> pprPanic "tcSplicePat: encountered unexpanded top-level untyped splice" (ppr splice)
- ; Comp -> pprPanic "tcSplicePat: encountered unexpanded top-level untyped splice" (ppr splice)
- ; Brack isTypedBrack pop_stage ps_var lie_var -> do
-
- { checkTc (not isTypedBrack) illegalUntypedSplice
-
- ; meta_exp_ty <- tcMetaTy patQTyConName
- ; expr' <- setStage pop_stage $
- setConstraintVar lie_var $
- tcMonoExpr expr meta_exp_ty
- ; ps <- readMutVar ps_var
- ; writeMutVar ps_var (PendingTcSplice name expr' : ps)
-
- -- The returned expression is ignored
- ; return (panic "tcSplicePat")
- }}}
+tcSpliceDecls splice
+ = pprPanic "tcSpliceDecls: encountered a typed type splice" (ppr splice)
\end{code}
%************************************************************************
@@ -587,79 +543,6 @@ We don't want the type checker to see these bogus unbound variables.
%************************************************************************
%* *
- Splicing a type
-%* *
-%************************************************************************
-
-Very like splicing an expression, but we don't yet share code.
-
-\begin{code}
-tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind)
-tcSpliceType splice@(HsSplice True _ _) _
- = pprPanic "tcSpliceType: encountered a typed type splice" (ppr splice)
-
-tcSpliceType splice@(HsSplice False name expr) _
- = setSrcSpan (getLoc expr) $ do
- { stage <- getStage
- ; case stage of
- { Brack isTypedBrack pop_stage ps_var lie_var -> do
-
- -- See Note [How brackets and nested splices are handled]
- -- A splice inside brackets
- { meta_ty <- tcMetaTy typeQTyConName
- ; when isTypedBrack $
- failWithTc illegalUntypedSplice
-
- ; expr' <- setStage pop_stage $
- setConstraintVar lie_var $
- tcMonoExpr expr meta_ty
-
- -- Write the pending splice into the bucket
- ; ps <- readMutVar ps_var
- ; writeMutVar ps_var (PendingTcSplice name expr' : ps)
-
- -- e.g. [| f (g :: Int -> $(h 4)) |]
- -- Here (h 4) :: Q Type
- -- but $(h 4) :: a i.e. any type, of any kind
-
- ; kind <- newMetaKindVar
- ; ty <- newFlexiTyVarTy kind
- ; return (ty, kind)
- }
-
- ; _ -> pprPanic "tcSpliceType: encountered unexpanded top-level type splice" (ppr splice)
- }}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Splicing an expression}
-%* *
-%************************************************************************
-
-\begin{code}
--- Note [How top-level splices are handled]
--- Always at top level
--- Type sig at top of file:
--- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
-tcSpliceDecls splice@(HsSplice True _ _)
- = pprPanic "tcSpliceDecls: encountered a typed type splice" (ppr splice)
-
-tcSpliceDecls (HsSplice False _ expr)
- = do { list_q <- tcMetaTy decsQTyConName -- Q [Dec]
- ; zonked_q_expr <- tcTopSpliceExpr False (tcMonoExpr expr list_q)
-
- -- Run the expression
- ; decls <- runMetaD zonked_q_expr
- ; showSplice "declarations" expr
- (ppr (getLoc expr) $$ (vcat (map ppr decls)))
-
- ; return decls }
-\end{code}
-
-
-%************************************************************************
-%* *
Annotations
%* *
%************************************************************************
@@ -1061,7 +944,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
= bindName name
checkTopDecl _
= addErr $ text "Only function, value, and foreign import declarations may be added with addTopDecl"
-
+
bindName :: RdrName -> TcM ()
bindName (Exact n)
= do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
@@ -1108,21 +991,6 @@ showSplice what before after
nest 2 (sep [nest 2 (ppr before),
text "======>",
nest 2 after])]) }
-
-illegalBracket :: SDoc
-illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
-
-illegalTypedBracket :: SDoc
-illegalTypedBracket = ptext (sLit "Typed brackets may only appear in typed slices.")
-
-illegalUntypedBracket :: SDoc
-illegalUntypedBracket = ptext (sLit "Untyped brackets may only appear in untyped slices.")
-
-illegalTypedSplice :: SDoc
-illegalTypedSplice = ptext (sLit "Typed splices may not appear in untyped brackets")
-
-illegalUntypedSplice :: SDoc
-illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brackets")
\end{code}
diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot
index 07ba144958..b96cf18311 100644
--- a/compiler/typecheck/TcSplice.lhs-boot
+++ b/compiler/typecheck/TcSplice.lhs-boot
@@ -2,7 +2,7 @@
module TcSplice where
import HsSyn ( HsSplice, HsBracket, HsQuasiQuote,
HsExpr, LHsType, LHsExpr, LPat, LHsDecl )
-import HsExpr ( PendingSplice )
+import HsExpr ( PendingRnSplice )
import Id ( Id )
import Name ( Name )
import RdrName ( RdrName )
@@ -14,16 +14,19 @@ import Annotations ( Annotation, CoreAnnTarget )
import qualified Language.Haskell.TH as TH
#endif
-tcSpliceExpr :: HsSplice Name
+tcSpliceExpr :: Bool -> HsSplice Name
-> TcRhoType
-> TcM (HsExpr TcId)
tcSpliceDecls :: HsSplice Name -> TcM [LHsDecl RdrName]
-tcBracket :: HsBracket Name
- -> [PendingSplice]
- -> TcRhoType
- -> TcM (HsExpr TcId)
+tcUntypedBracket :: HsBracket Name
+ -> [PendingRnSplice]
+ -> TcRhoType
+ -> TcM (HsExpr TcId)
+tcTypedBracket :: HsBracket Name
+ -> TcRhoType
+ -> TcM (HsExpr TcId)
tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id)
View Lorry Controller Status