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

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) = ...@@ -571,9 +571,10 @@ addTickHsExpr (HsCoreAnn nm e) =
liftM2 HsCoreAnn liftM2 HsCoreAnn
(return nm) (return nm)
(addTickLHsExpr e) (addTickLHsExpr e)
addTickHsExpr e@(HsBracket {}) = return e addTickHsExpr e@(HsBracket {}) = return e
addTickHsExpr e@(HsBracketOut {}) = return e addTickHsExpr e@(HsTcBracketOut {}) = return e
addTickHsExpr e@(HsSpliceE {}) = return e addTickHsExpr e@(HsRnBracketOut {}) = return e
addTickHsExpr e@(HsSpliceE {}) = return e
addTickHsExpr (HsProc pat cmdtop) = addTickHsExpr (HsProc pat cmdtop) =
liftM2 HsProc liftM2 HsProc
(addTickLPat pat) (addTickLPat pat)
......
...@@ -559,11 +559,11 @@ Here is where we desugar the Template Haskell brackets and escapes ...@@ -559,11 +559,11 @@ Here is where we desugar the Template Haskell brackets and escapes
dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
#ifdef GHCI #ifdef GHCI
dsExpr (HsBracketOut x ps) = dsBracket x ps dsExpr (HsTcBracketOut x ps) = dsBracket x ps
#else #else
dsExpr (HsBracketOut _ _) = panic "dsExpr HsBracketOut" dsExpr (HsTcBracketOut _ _) = panic "dsExpr HsBracketOut"
#endif #endif
dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s) dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
-- Arrow notation extension -- Arrow notation extension
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
......
...@@ -67,7 +67,7 @@ import Control.Monad ...@@ -67,7 +67,7 @@ import Control.Monad
import Data.List import Data.List
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr
-- Returns a CoreExpr of type TH.ExpQ -- Returns a CoreExpr of type TH.ExpQ
-- The quoted thing is parameterised over Name, even though it has -- The quoted thing is parameterised over Name, even though it has
-- been type checked. We don't want all those type decorations! -- been type checked. We don't want all those type decorations!
...@@ -75,7 +75,7 @@ dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr ...@@ -75,7 +75,7 @@ dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
dsBracket brack splices dsBracket brack splices
= dsExtendMetaEnv new_bit (do_brack brack) = dsExtendMetaEnv new_bit (do_brack brack)
where 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 (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
...@@ -835,7 +835,7 @@ repTy (HsKindSig t k) = do ...@@ -835,7 +835,7 @@ repTy (HsKindSig t k) = do
t1 <- repLTy t t1 <- repLTy t
k1 <- repLKind k k1 <- repLKind k
repTSig t1 k1 repTSig t1 k1
repTy (HsSpliceTy splice _ _) = repSplice splice repTy (HsSpliceTy splice _) = repSplice splice
repTy (HsExplicitListTy _ tys) = do repTy (HsExplicitListTy _ tys) = do
tys1 <- repLTys tys tys1 <- repLTys tys
repTPromotedList tys1 repTPromotedList tys1
...@@ -903,7 +903,7 @@ repRole (L _ Nothing) = rep2 inferRName [] ...@@ -903,7 +903,7 @@ repRole (L _ Nothing) = rep2 inferRName []
repSplice :: HsSplice Name -> DsM (Core a) repSplice :: HsSplice Name -> DsM (Core a)
-- See Note [How brackets and nested splices are handled] in TcSplice -- See Note [How brackets and nested splices are handled] in TcSplice
-- We return a CoreExpr of any old type; the context should know -- We return a CoreExpr of any old type; the context should know
repSplice (HsSplice _ n _) repSplice (HsSplice n _)
= do { mb_val <- dsLookupMetaEnv n = do { mb_val <- dsLookupMetaEnv n
; case mb_val of ; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e Just (Splice e) -> do { e' <- dsExpr e
...@@ -1026,13 +1026,13 @@ repE (ArithSeq _ _ aseq) = ...@@ -1026,13 +1026,13 @@ repE (ArithSeq _ _ aseq) =
ds3 <- repLE e3 ds3 <- repLE e3
repFromThenTo ds1 ds2 ds3 repFromThenTo ds1 ds2 ds3
repE (HsSpliceE splice) = repSplice splice repE (HsSpliceE _ splice) = repSplice splice
repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e) repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)
repE e = notHandled "Expression form" (ppr e) repE e = notHandled "Expression form" (ppr e)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt, -- Building representations of auxillary structures like Match, Clause, Stmt,
......
...@@ -67,7 +67,7 @@ module HsDecls ( ...@@ -67,7 +67,7 @@ module HsDecls (
) where ) where
-- friends: -- friends:
import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr ) import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, pprUntypedSplice )
-- Because Expr imports Decls via HsBracket -- Because Expr imports Decls via HsBracket
import HsBinds import HsBinds
...@@ -290,7 +290,7 @@ data SpliceDecl id ...@@ -290,7 +290,7 @@ data SpliceDecl id
deriving (Data, Typeable) deriving (Data, Typeable)
instance OutputableBndr name => Outputable (SpliceDecl name) where instance OutputableBndr name => Outputable (SpliceDecl name) where
ppr (SpliceDecl e _) = ppr e ppr (SpliceDecl (L _ e) _) = pprUntypedSplice e
\end{code} \end{code}
......
...@@ -246,20 +246,20 @@ data HsExpr id ...@@ -246,20 +246,20 @@ data HsExpr id
| HsBracket (HsBracket id) | HsBracket (HsBracket id)
-- See Note [Pending Renamer Splices] -- See Note [Pending Splices]
| HsRnBracketOut (HsBracket Name) -- Output of the renamer is | HsRnBracketOut
-- the *original* (HsBracket Name) -- Output of the renamer is the *original* renamed
[PendingSplice] -- renamed expression, plus -- expression, plus
-- _renamed_ splices to be [PendingRnSplice] -- _renamed_ splices to be type checked
-- type checked
| HsBracketOut (HsBracket Name) -- Output of the type checker is | HsTcBracketOut
-- the *original* (HsBracket Name) -- Output of the type checker is the *original*
[PendingSplice] -- renamed expression, plus -- renamed expression, plus
-- _typechecked_ splices to be [PendingTcSplice] -- _typechecked_ splices to be
-- pasted back in by the desugarer -- pasted back in by the desugarer
| HsSpliceE (HsSplice id) | HsSpliceE Bool -- True <=> typed splice
(HsSplice id) -- False <=> untyped
| HsQuasiQuoteE (HsQuasiQuote id) | HsQuasiQuoteE (HsQuasiQuote id)
-- See Note [Quasi-quote overview] in TcSplice -- See Note [Quasi-quote overview] in TcSplice
...@@ -346,14 +346,15 @@ tupArgPresent (Present {}) = True ...@@ -346,14 +346,15 @@ tupArgPresent (Present {}) = True
tupArgPresent (Missing {}) = False tupArgPresent (Missing {}) = False
-- See Note [Pending Splices] -- See Note [Pending Splices]
data PendingSplice data PendingRnSplice
= PendingRnExpSplice Name (LHsExpr Name) = PendingRnExpSplice (HsSplice Name)
| PendingRnPatSplice Name (LHsExpr Name) | PendingRnPatSplice (HsSplice Name)
| PendingRnTypeSplice Name (LHsExpr Name) | PendingRnTypeSplice (HsSplice Name)
| PendingRnDeclSplice Name (LHsExpr Name) | PendingRnDeclSplice (HsSplice Name)
| PendingRnCrossStageSplice Name | PendingRnCrossStageSplice Name
| PendingTcSplice Name (LHsExpr Id)
deriving (Data, Typeable) deriving (Data, Typeable)
type PendingTcSplice = (Name, LHsExpr Id)
\end{code} \end{code}
Note [Pending Splices] Note [Pending Splices]
...@@ -598,12 +599,12 @@ ppr_expr (HsSCC lbl expr) ...@@ -598,12 +599,12 @@ ppr_expr (HsSCC lbl expr)
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
ppr_expr (HsType id) = ppr id ppr_expr (HsType id) = ppr id
ppr_expr (HsSpliceE s) = pprSplice s ppr_expr (HsSpliceE t s) = pprSplice t s
ppr_expr (HsBracket b) = pprHsBracket b ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsRnBracketOut e []) = ppr e ppr_expr (HsRnBracketOut e []) = ppr e
ppr_expr (HsRnBracketOut e ps) = ppr e $$ ptext (sLit "pending(rn)") <+> ppr ps ppr_expr (HsRnBracketOut e ps) = ppr e $$ ptext (sLit "pending(rn)") <+> ppr ps
ppr_expr (HsBracketOut e []) = ppr e ppr_expr (HsTcBracketOut e []) = ppr e
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending(tc)") <+> ppr ps ppr_expr (HsTcBracketOut e ps) = ppr e $$ ptext (sLit "pending(tc)") <+> ppr ps
ppr_expr (HsQuasiQuoteE qq) = ppr qq ppr_expr (HsQuasiQuoteE qq) = ppr qq
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
...@@ -687,7 +688,7 @@ hsExprNeedsParens (ExplicitPArr {}) = False ...@@ -687,7 +688,7 @@ hsExprNeedsParens (ExplicitPArr {}) = False
hsExprNeedsParens (HsPar {}) = False hsExprNeedsParens (HsPar {}) = False
hsExprNeedsParens (HsBracket {}) = False hsExprNeedsParens (HsBracket {}) = False
hsExprNeedsParens (HsRnBracketOut {}) = False hsExprNeedsParens (HsRnBracketOut {}) = False
hsExprNeedsParens (HsBracketOut _ []) = False hsExprNeedsParens (HsTcBracketOut {}) = False
hsExprNeedsParens (HsDo sc _ _) hsExprNeedsParens (HsDo sc _ _)
| isListCompExpr sc = False | isListCompExpr sc = False
hsExprNeedsParens _ = True hsExprNeedsParens _ = True
...@@ -1371,17 +1372,19 @@ pprQuals quals = interpp'SP quals ...@@ -1371,17 +1372,19 @@ pprQuals quals = interpp'SP quals
\begin{code} \begin{code}
data HsSplice id = HsSplice -- $z or $(f 4) data HsSplice id = HsSplice -- $z or $(f 4)
Bool -- True if typed, False if untyped
id -- The id is just a unique name to id -- The id is just a unique name to
(LHsExpr id) -- identify this splice point (LHsExpr id) -- identify this splice point
deriving (Data, Typeable) deriving (Data, Typeable)
instance OutputableBndr id => Outputable (HsSplice id) where 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 :: OutputableBndr id => Bool -> HsSplice id -> SDoc
pprSplice (HsSplice isTyped n e) pprSplice is_typed (HsSplice n e)
= (if isTyped then ptext (sLit "$$") else char '$') = (if is_typed then ptext (sLit "$$") else char '$')
<> ifPprDebug (brackets (ppr n)) <> eDoc <> ifPprDebug (brackets (ppr n)) <> eDoc
where where
-- We use pprLExpr to match pprParendExpr: -- We use pprLExpr to match pprParendExpr:
...@@ -1428,13 +1431,12 @@ thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> ...@@ -1428,13 +1431,12 @@ thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
thTyBrackets :: SDoc -> SDoc thTyBrackets :: SDoc -> SDoc
thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]") thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]")
instance Outputable PendingSplice where instance Outputable PendingRnSplice where
ppr (PendingRnExpSplice name expr) = ppr (name, expr) ppr (PendingRnExpSplice s) = ppr s
ppr (PendingRnPatSplice name expr) = ppr (name, expr) ppr (PendingRnPatSplice s) = ppr s
ppr (PendingRnTypeSplice name expr) = ppr (name, expr) ppr (PendingRnTypeSplice s) = ppr s
ppr (PendingRnDeclSplice name expr) = ppr (name, expr) ppr (PendingRnDeclSplice s) = ppr s
ppr (PendingRnCrossStageSplice name) = ppr name ppr (PendingRnCrossStageSplice name) = ppr name
ppr (PendingTcSplice name expr) = ppr (name, expr)
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -33,7 +33,6 @@ instance Data i => Data (HsCmd i) ...@@ -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 (MatchGroup i body)
instance (Data i, Data body) => Data (GRHSs 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 (HsExpr id)
instance OutputableBndr id => Outputable (HsCmd id) instance OutputableBndr id => Outputable (HsCmd id)
...@@ -46,8 +45,8 @@ pprLExpr :: (OutputableBndr i) => ...@@ -46,8 +45,8 @@ pprLExpr :: (OutputableBndr i) =>
pprExpr :: (OutputableBndr i) => pprExpr :: (OutputableBndr i) =>
HsExpr i -> SDoc HsExpr i -> SDoc
pprSplice :: (OutputableBndr i) => pprUntypedSplice :: (OutputableBndr i) =>
HsSplice i -> SDoc HsSplice i -> SDoc
pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body) pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body)
=> LPat bndr -> GRHSs id body -> SDoc => LPat bndr -> GRHSs id body -> SDoc
......
...@@ -23,7 +23,7 @@ module HsPat ( ...@@ -23,7 +23,7 @@ module HsPat (
pprParendLPat pprParendLPat
) where ) where
import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr) import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprUntypedSplice)
-- friends: -- friends:
import HsBinds import HsBinds
...@@ -271,7 +271,7 @@ pprPat (LitPat s) = ppr s ...@@ -271,7 +271,7 @@ pprPat (LitPat s) = ppr s
pprPat (NPat l Nothing _) = ppr l pprPat (NPat l Nothing _) = ppr l
pprPat (NPat l (Just _) _) = char '-' <> ppr l pprPat (NPat l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] 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 (QuasiQuotePat qq) = ppr qq
pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
......
...@@ -38,11 +38,10 @@ module HsTypes ( ...@@ -38,11 +38,10 @@ module HsTypes (
pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
) where ) where
import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice )
import HsLit import HsLit
import NameSet( FreeVars )
import Name( Name ) import Name( Name )
import RdrName( RdrName ) import RdrName( RdrName )
import DataCon( HsBang(..) ) import DataCon( HsBang(..) )
...@@ -230,7 +229,6 @@ data HsType name ...@@ -230,7 +229,6 @@ data HsType name
| HsQuasiQuoteTy (HsQuasiQuote name) | HsQuasiQuoteTy (HsQuasiQuote name)
| HsSpliceTy (HsSplice name) | HsSpliceTy (HsSplice name)
FreeVars -- Variables free in the splice (filled in by renamer)
PostTcKind PostTcKind
| HsDocTy (LHsType name) LHsDocString -- A documented type | 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 ...@@ -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 _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = paBrackets (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 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 _ (HsCoreTy ty) = ppr ty
ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys) ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys) ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
......
...@@ -55,7 +55,8 @@ module HsUtils( ...@@ -55,7 +55,8 @@ module HsUtils(
emptyRecStmt, mkRecStmt, emptyRecStmt, mkRecStmt,
-- Template Haskell -- Template Haskell
unqualSplice, mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkHsQuasiQuote, unqualQuasiQuote, mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkHsSplice,
mkHsQuasiQuote, unqualQuasiQuote,
-- Flags -- Flags
noRebindableInfo, noRebindableInfo,
...@@ -251,17 +252,17 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } ...@@ -251,17 +252,17 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
mkHsSplice :: Bool -> LHsExpr RdrName -> HsSplice RdrName mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
mkHsSplice isTyped e = HsSplice isTyped unqualSplice e mkHsSplice e = HsSplice unqualSplice e
mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
mkHsSpliceE e = HsSpliceE (mkHsSplice False e) mkHsSpliceE e = HsSpliceE False (mkHsSplice e)
mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
mkHsSpliceTE e = HsSpliceE (mkHsSplice True e) mkHsSpliceTE e = HsSpliceE True (mkHsSplice e)
mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
mkHsSpliceTy e = HsSpliceTy (mkHsSplice False e) emptyFVs placeHolderKind mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) placeHolderKind
unqualSplice :: RdrName unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
......
% o%
% (c) The University of Glasgow, 1996-2003 % (c) The University of Glasgow, 1996-2003
Functions over HsSyn specialised to RdrName. Functions over HsSyn specialised to RdrName.
...@@ -235,11 +235,13 @@ mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName ...@@ -235,11 +235,13 @@ mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
-- but if she wrote, say, -- but if she wrote, say,
-- f x then behave as if she'd written $(f x) -- f x then behave as if she'd written $(f x)
-- ie a SpliceD -- ie a SpliceD
mkSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq mkSpliceDecl lexpr@(L loc expr)
mkSpliceDecl (L loc (HsSpliceE splice)) = SpliceD (SpliceDecl (L loc splice) Explicit) | HsQuasiQuoteE qq <- expr = QuasiQuoteD qq
mkSpliceDecl other_expr = SpliceD (SpliceDecl (L (getLoc other_expr) splice) Implicit) | HsSpliceE is_typed splice <- expr = ASSERT( not is_typed )
SpliceD (SpliceDecl (L loc splice) Explicit)
| otherwise = SpliceD (SpliceDecl (L loc splice) Implicit)
where where
HsSpliceE splice = mkHsSpliceE other_expr splice = mkHsSplice lexpr
mkTyLit :: Located (HsTyLit) -> P (LHsType RdrName) mkTyLit :: Located (HsTyLit) -> P (LHsType RdrName)
mkTyLit l = mkTyLit l =
...@@ -675,11 +677,12 @@ checkAPat msg loc e0 = do ...@@ -675,11 +677,12 @@ checkAPat msg loc e0 = do
| otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
RecordCon c _ (HsRecFields fs dd) RecordCon c _ (HsRecFields fs dd)
-> do fs <- mapM (checkPatField msg) fs -> do fs <- mapM (checkPatField msg) fs
return (ConPatIn c (RecCon (HsRecFields fs dd))) return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsSpliceE s -> return (SplicePat s) HsSpliceE is_typed s | not is_typed
HsQuasiQuoteE q -> return (QuasiQuotePat q) -> return (SplicePat s)
_ -> patFail msg loc e0 HsQuasiQuoteE q -> return (QuasiQuotePat q)
_ -> patFail msg loc e0
placeHolderPunRhs :: LHsExpr RdrName placeHolderPunRhs :: LHsExpr RdrName
-- The RHS of a punned record field will be filled in by the renamer -- The RHS of a punned record field will be filled in by the renamer
......
...@@ -24,7 +24,7 @@ import HsSyn ...@@ -24,7 +24,7 @@ import HsSyn
import TcRnMonad import TcRnMonad
import Module ( getModule ) import Module ( getModule )
import RnEnv import RnEnv
import RnSplice import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName )
import RnTypes import RnTypes
import RnPat import RnPat
import DynFlags import DynFlags
...@@ -174,7 +174,7 @@ rnExpr (NegApp e _) ...@@ -174,7 +174,7 @@ rnExpr (NegApp e _)
-- (not with an rnExpr crash) in a stage-1 compiler. -- (not with an rnExpr crash) in a stage-1 compiler.
rnExpr e@(HsBracket br_body) = rnBracket e br_body 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) rnExpr (HsQuasiQuoteE qq)
......
\begin{code} \begin{code}
module RnSplice ( module RnSplice (
rnSplice, rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, rnTopSpliceDecls,
rnBracket, checkTH, rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
rnBracket,
checkThLocalName checkThLocalName
) where ) where
...@@ -15,13 +16,13 @@ import TcRnMonad ...@@ -15,13 +16,13 @@ import TcRnMonad
#ifdef GHCI #ifdef GHCI
import Control.Monad ( unless, when ) import Control.Monad ( unless, when )
import DynFlags import DynFlags
import DsMeta ( expQTyConName, patQTyConName, typeQTyConName ) import DsMeta ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName )
import LoadIface ( loadInterfaceForName ) import LoadIface ( loadInterfaceForName )
import Module import Module
import RnEnv import RnEnv
import RnPat import RnPat ( rnPat )
import RnSource ( rnSrcDecls, findSplice ) import RnSource ( rnSrcDecls, findSplice )
import RnTypes import RnTypes ( rnLHsType )
import SrcLoc import SrcLoc
import TcEnv ( checkWellStaged, tcMetaTy ) import TcEnv ( checkWellStaged, tcMetaTy )
import Outputable import Outputable
...@@ -30,7 +31,7 @@ import FastString ...@@ -30,7 +31,7 @@ import FastString
import {-# SOURCE #-} RnExpr ( rnLExpr ) import {-# SOURCE #-} RnExpr ( rnLExpr )
import {-# SOURCE #-} TcExpr ( tcMonoExpr ) import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcSplice ( runMetaE, runMetaP, runMetaT, tcTopSpliceExpr ) import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
#endif #endif
\end{code} \end{code}
...@@ -39,14 +40,14 @@ import {-# SOURCE #-} TcSplice ( runMetaE, runMetaP, runMetaT, tcTopSpliceExpr ) ...@@ -39,14 +40,14 @@ import {-# SOURCE #-} TcSplice ( runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
rnBracket e _ = failTH e "Template Haskell bracket" rnBracket e _ = failTH e "Template Haskell bracket"
rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
rnSplice e = failTH e "Template Haskell splice" rnTopSpliceDecls e = failTH e "Template Haskell top splice"
rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
rnSpliceType e _ = failTH e "Template Haskell type splice" rnSpliceType e _ = failTH e "Template Haskell type splice"
rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) rnSpliceExpr :: Bool -> HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceExpr e = failTH e "Template Haskell splice" rnSpliceExpr _ e = failTH e "Template Haskell splice"
rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars) rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars)
rnSplicePat e = failTH e "Template Haskell pattern splice" 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 ...@@ -82,210 +83,162 @@ thereby get some bogus unused-import warnings, but we won't crash the
type checker. Not very satisfactory really. type checker. Not very satisfactory really.
\begin{code} \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