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)
......
This diff is collapsed.
......@@ -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}
......@@ -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
......
%
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)
......
......@@ -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
......
......@@ -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) $
......
......@@ -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
......
This diff is collapsed.
......@@ -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)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment