Commit 51deeb0d authored by Simon Peyton Jones's avatar Simon Peyton Jones

Another raft of Template Haskell clean-up

The handling of typed and untyped brackets was extremely convoluted,
partly because of the evolutionary history.  I've tidied it all up.

See Note [How brackets and nested splices are handled] in TcSplice
for the full story

Main changes:

 * Untyped brackets: after the renamer, HsRnBracketOut carries
   PendingRnSplices for splices in untyped brackets.  In the
   typechecker, these pending splices are typechecked quite
   straigtforwardly, with no ps_var nonsense.

 * Typed brackets: after the renamer typed brackest still look
   like HsBracket. The type checker does the ps_var thing.

 * In TcRnTypes.ThStage, the Brack constructor, we distinguish
   the renaming from typehecking pending-stuff.  Much more
   perspicuous!

 * The "typed" flag is in HsSpliceE, not in HsSplice, because
   only expressions can be typed.  Patterns, types, declarations
   cannot.

There is further improvement to be done to make the handling of
declaration splices more uniform.
parent f8b25c30
......@@ -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)
......
......@@ -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
......
......@@ -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,
......
......@@ -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}
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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"))
......
%
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
......
......@@ -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)
......
\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