Commit 1e436f2b authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Three improvements to Template Haskell (fixes #3467)

This patch implements three significant improvements to Template Haskell.
  
Declaration-level splices with no "$" 
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This change simply allows you to omit the "$(...)" wrapper for 
declaration-level TH splices.  An expression all by itself is
not legal, so we now treat it as a TH splice.  Thus you can now
say
	data T = T1 | T2
 	deriveMyStuff ''T

where deriveMyStuff :: Name -> Q [Dec]
This makes a much nicer interface for clients of libraries that use
TH: no scary $(deriveMyStuff ''T).

Nested top-level splices
~~~~~~~~~~~~~~~~~~~~~~~~
Previously TH would reject this, saying that splices cannot be nested:
	f x = $(g $(h 'x))
But there is no reason for this not to work.  First $(h 'x) is run,
yielding code <blah> that is spliced instead of the $(h 'x). Then (g
<blah>) is typechecked and run, yielding code that replaces the
$(g ...) splice.  

So this simply lifts the restriction.

Fix Trac #3467: non-top-level type splices
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

It appears that when I added the ability to splice types in TH
programs, I failed to pay attention to non-top-level splices -- that
is, splices inside quotatation brackets.  

This patch fixes the problem.  I had to modify HsType, so there's a
knock-on change to Haddock.

Its seems that a lot of lines of code has changed, but almost all the
new lines are comments!

General tidying up
~~~~~~~~~~~~~~~~~~
As a result of thinking all this out I re-jigged the data type ThStage,
which had far too many values before.  And I wrote a nice state transition
diagram to make it all precise; 
   see Note [Template Haskell state diagram] in TcSplice

Lots more refactoring in TcSplice, resulting in significantly less code.
(A few more lines, but actually less code -- the rest is comments.)

I think the result is significantly cleaner.
parent c281c075
......@@ -587,43 +587,44 @@ repTy (HsForAllTy _ tvs ctxt ty) =
repTForall bndrs1 ctxt1 ty1
repTy (HsTyVar n)
| isTvOcc (nameOccName n) = do
tv1 <- lookupTvOcc n
repTvar tv1
| otherwise = do
tc1 <- lookupOcc n
repNamedTyCon tc1
repTy (HsAppTy f a) = do
f1 <- repLTy f
a1 <- repLTy a
repTapp f1 a1
repTy (HsFunTy f a) = do
f1 <- repLTy f
a1 <- repLTy a
tcon <- repArrowTyCon
repTapps tcon [f1, a1]
repTy (HsListTy t) = do
t1 <- repLTy t
tcon <- repListTyCon
repTapp tcon t1
repTy (HsPArrTy t) = do
t1 <- repLTy t
tcon <- repTy (HsTyVar (tyConName parrTyCon))
repTapp tcon t1
repTy (HsTupleTy _ tys) = do
tys1 <- repLTys tys
tcon <- repTupleTyCon (length tys)
repTapps tcon tys1
repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
`nlHsAppTy` ty2)
repTy (HsParTy t) = repLTy t
repTy (HsPredTy pred) = repPredTy pred
repTy (HsKindSig t k) = do
t1 <- repLTy t
k1 <- repKind k
repTSig t1 k1
repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
repTy ty = notHandled "Exotic form of type" (ppr ty)
| isTvOcc (nameOccName n) = do
tv1 <- lookupTvOcc n
repTvar tv1
| otherwise = do
tc1 <- lookupOcc n
repNamedTyCon tc1
repTy (HsAppTy f a) = do
f1 <- repLTy f
a1 <- repLTy a
repTapp f1 a1
repTy (HsFunTy f a) = do
f1 <- repLTy f
a1 <- repLTy a
tcon <- repArrowTyCon
repTapps tcon [f1, a1]
repTy (HsListTy t) = do
t1 <- repLTy t
tcon <- repListTyCon
repTapp tcon t1
repTy (HsPArrTy t) = do
t1 <- repLTy t
tcon <- repTy (HsTyVar (tyConName parrTyCon))
repTapp tcon t1
repTy (HsTupleTy _ tys) = do
tys1 <- repLTys tys
tcon <- repTupleTyCon (length tys)
repTapps tcon tys1
repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
`nlHsAppTy` ty2)
repTy (HsParTy t) = repLTy t
repTy (HsPredTy pred) = repPredTy pred
repTy (HsKindSig t k) = do
t1 <- repLTy t
k1 <- repKind k
repTSig t1 k1
repTy (HsSpliceTy splice) = repSplice splice
repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
repTy ty = notHandled "Exotic form of type" (ppr ty)
-- represent a kind
--
......@@ -639,6 +640,21 @@ repKind ki
| otherwise = notHandled "Exotic form of kind"
(ppr k)
-----------------------------------------------------------------------------
-- Splices
-----------------------------------------------------------------------------
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 _)
= do { mb_val <- dsLookupMetaEnv n
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
; return (MkC e') }
_ -> pprPanic "HsSplice" (ppr n) }
-- Should not happen; statically checked
-----------------------------------------------------------------------------
-- Expressions
-----------------------------------------------------------------------------
......@@ -742,14 +758,8 @@ repE (ArithSeq _ aseq) =
ds2 <- repLE e2
ds3 <- repLE e3
repFromThenTo ds1 ds2 ds3
repE (HsSpliceE (HsSplice n _))
= do { mb_val <- dsLookupMetaEnv n
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
; return (MkC e') }
_ -> pprPanic "HsSplice" (ppr n) }
-- Should not happen; statically checked
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)
......
......@@ -159,6 +159,9 @@ data HsType name
| HsDocTy (LHsType name) LHsDocString -- A documented type
| HsSpliceTyOut Kind -- Used just like KindedTyVar, just between
-- kcHsType and dsHsType
| HsBangTy HsBang (LHsType name) -- Bang-style type annotations
| HsRecTy [ConDeclField name] -- Only in data type declarations
......@@ -369,17 +372,18 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
= maybeParen ctxt_prec pREC_FUN $
sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr ty
ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds
ppr_mono_ty _ (HsTyVar name) = ppr name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2
ppr_mono_ty _ (HsTupleTy con tys) = tupleParens con (interpp'SP tys)
ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
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 _ (HsPredTy pred) = ppr pred
ppr_mono_ty _ (HsNumTy n) = integer n -- generics only
ppr_mono_ty _ (HsSpliceTy s) = pprSplice s
ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr ty
ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds
ppr_mono_ty _ (HsTyVar name) = ppr name
ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2
ppr_mono_ty _ (HsTupleTy con tys) = tupleParens con (interpp'SP tys)
ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
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 _ (HsPredTy pred) = ppr pred
ppr_mono_ty _ (HsNumTy n) = integer n -- generics only
ppr_mono_ty _ (HsSpliceTy s) = pprSplice s
ppr_mono_ty _ (HsSpliceTyOut k) = text "<splicety>" <> dcolon <> ppr k
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
= maybeParen ctxt_prec pREC_CON $
......
......@@ -542,7 +542,7 @@ data Token
| ITprimfloat Rational
| ITprimdouble Rational
-- MetaHaskell extension tokens
-- Template Haskell extension tokens
| ITopenExpQuote -- [| or [e|
| ITopenPatQuote -- [p|
| ITopenDecQuote -- [d|
......
......@@ -262,9 +262,9 @@ incorrect.
'{-# SCC' { L _ ITscc_prag }
'{-# GENERATED' { L _ ITgenerated_prag }
'{-# DEPRECATED' { L _ ITdeprecated_prag }
'{-# WARNING' { L _ ITwarning_prag }
'{-# WARNING' { L _ ITwarning_prag }
'{-# UNPACK' { L _ ITunpack_prag }
'{-# ANN' { L _ ITann_prag }
'{-# ANN' { L _ ITann_prag }
'#-}' { L _ ITclose_prag }
'..' { L _ ITdotdot } -- reserved symbols
......@@ -559,17 +559,17 @@ topdecl :: { OrdList (LHsDecl RdrName) }
| stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) }
| 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
| 'foreign' fdecl { unitOL (LL (unLoc $2)) }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# WARNING' warnings '#-}' { $2 }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# WARNING' warnings '#-}' { $2 }
| '{-# RULES' rules '#-}' { $2 }
| annotation { unitOL $1 }
| decl { unLoc $1 }
-- Template Haskell Extension
| '$(' exp ')' { unitOL (LL $ SpliceD (SpliceDecl $2)) }
| TH_ID_SPLICE { unitOL (LL $ SpliceD (SpliceDecl $
L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1))
)) }
-- The $(..) form is one possible form of infixexp
-- but we treat an arbitrary expression just as if
-- it had a $(..) wrapped around it
| infixexp { unitOL (LL $ mkTopSpliceDecl $1) }
-- Type classes
--
......
......@@ -10,7 +10,7 @@ module RdrHsSyn (
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice,
mkHsDo, mkHsSplice, mkTopSpliceDecl,
mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
splitCon, mkInlineSpec,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
......@@ -128,7 +128,8 @@ extract_lty (L loc ty) acc
HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
HsParTy ty -> extract_lty ty acc
HsNumTy _ -> acc
HsSpliceTy _ -> acc -- Type splices mention no type variables
HsSpliceTy {} -> acc -- Type splices mention no type variables
HsSpliceTyOut {} -> acc -- Type splices mention no type variables
HsKindSig ty _ -> extract_lty ty acc
HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
......@@ -223,6 +224,20 @@ mkTyFamily loc flavour lhs ksig
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars tparams
; return (L loc (TyFamily flavour tc tyvars ksig)) }
mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
-- If the user wrote
-- $(e)
-- then that's the splice, but if she wrote, say,
-- f x
-- then behave as if she'd written
-- $(f x)
mkTopSpliceDecl expr
= SpliceD (SpliceDecl expr')
where
expr' = case expr of
(L _ (HsSpliceE (HsSplice _ expr))) -> expr
_other -> expr
\end{code}
%************************************************************************
......
......@@ -68,7 +68,8 @@ extractHsTyNames ty
get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds)
get (HsNumTy _) = emptyNameSet
get (HsTyVar tv) = unitNameSet tv
get (HsSpliceTy _) = emptyNameSet -- Type splices mention no type variables
get (HsSpliceTy {}) = emptyNameSet -- Type splices mention no type variables
get (HsSpliceTyOut {}) = emptyNameSet -- Ditto
get (HsKindSig ty _) = getl ty
get (HsForAllTy _ tvs
ctxt ty) = (extractHsCtxtTyNames ctxt
......
......@@ -191,6 +191,8 @@ rnHsType doc (HsDocTy ty haddock_doc) = do
haddock_doc' <- rnLHsDoc haddock_doc
return (HsDocTy ty' haddock_doc')
rnHsType _ (HsSpliceTyOut {}) = panic "rnHsType"
rnLHsTypes :: SDoc -> [LHsType RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
rnLHsTypes doc tys = mapM (rnLHsType doc) tys
......
......@@ -867,7 +867,7 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
{ use_stage <- getStage
; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
(topIdLvl dfun_id) use_stage
(topIdLvl dfun_id) (thLevel use_stage)
-- It's possible that not all the tyvars are in
-- the substitution, tenv. For example:
......
......@@ -38,7 +38,7 @@ module TcEnv(
tcGetGlobalTyVars,
-- Template Haskell stuff
checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
checkWellStaged, tcMetaTy, thLevel,
topIdLvl, thTopLevelId, thRnBrack, isBrackStage,
-- New Ids
......@@ -526,41 +526,25 @@ tcExtendRules lcl_rules thing_inside
%************************************************************************
\begin{code}
instance Outputable ThStage where
ppr (Comp l) = text "Comp" <+> int l
ppr (Brack l _ _) = text "Brack" <+> int l
ppr (Splice l) = text "Splice" <+> int l
thLevel :: ThStage -> ThLevel
thLevel (Comp l) = l
thLevel (Splice l) = l
thLevel (Brack l _ _) = l
checkWellStaged :: SDoc -- What the stage check is for
-> ThLevel -- Binding level (increases inside brackets)
-> ThStage -- Use stage
-> ThLevel -- Use stage
-> TcM () -- Fail if badly staged, adding an error
checkWellStaged pp_thing bind_lvl use_stage
checkWellStaged pp_thing bind_lvl use_lvl
| use_lvl >= bind_lvl -- OK! Used later than bound
= return () -- E.g. \x -> [| $(f x) |]
| bind_lvl == topLevel -- GHC restriction on top level splices
| bind_lvl == outerLevel -- GHC restriction on top level splices
= failWithTc $
sep [ptext (sLit "GHC stage restriction:") <+> pp_thing,
nest 2 (ptext (sLit "is used in") <+> use_lvl_doc <> ptext (sLit ", and must be imported, not defined locally"))]
nest 2 (vcat [ ptext (sLit "is used in a top-level splice or annotation,")
, ptext (sLit ", and must be imported, not defined locally")])]
| otherwise -- Badly staged
= failWithTc $ -- E.g. \x -> $(f x)
ptext (sLit "Stage error:") <+> pp_thing <+>
hsep [ptext (sLit "is bound at stage") <+> ppr bind_lvl,
ptext (sLit "but used at stage") <+> ppr use_lvl]
where
use_lvl = thLevel use_stage
use_lvl_doc | use_lvl == thLevel topStage = ptext (sLit "a top-level splice")
| use_lvl == thLevel topAnnStage = ptext (sLit "an annotation")
| otherwise = panic "checkWellStaged"
topIdLvl :: Id -> ThLevel
-- Globals may either be imported, or may be from an earlier "chunk"
......@@ -572,19 +556,9 @@ topIdLvl :: Id -> ThLevel
-- $( f x )
-- By the time we are prcessing the $(f x), the binding for "x"
-- will be in the global env, not the local one.
topIdLvl id | isLocalId id = topLevel
topIdLvl id | isLocalId id = outerLevel
| otherwise = impLevel
-- Indicates the legal transitions on bracket( [| |] ).
bracketOK :: ThStage -> Maybe ThLevel
bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
bracketOK stage = Just (thLevel stage + 1)
-- Indicates the legal transitions on splice($).
spliceOK :: ThStage -> Maybe ThLevel
spliceOK (Splice _) = Nothing -- Splice illegal inside splice
spliceOK stage = Just (thLevel stage - 1)
tcMetaTy :: Name -> TcM Type
-- Given the name of a Template Haskell data type,
-- return the type
......
......@@ -12,7 +12,9 @@
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, addExprErrCtxt ) where
module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
tcInferRho, tcInferRhoNC, tcSyntaxOp,
addExprErrCtxt ) where
#include "HsVersions.h"
......@@ -890,9 +892,10 @@ tcId orig fun_name res_ty
tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
-- Typecheck a syntax operator, checking that it has the specified type
-- The operator is always a variable at this stage (i.e. renamer output)
-- This version assumes ty is a monotype
tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
---------------------------
instFun :: InstOrigin
-> HsExpr TcId
......@@ -1119,22 +1122,31 @@ lookupFun orig id_name
#ifndef GHCI /* GHCI and TH is off */
--------------------------------------
-- thLocalId : Check for cross-stage lifting
thLocalId orig id id_ty th_bind_lvl
thLocalId :: InstOrigin -> Id -> TcType -> ThLevel -> TcM ()
-- Check for cross-stage lifting
thLocalId orig id id_ty bind_lvl
= return ()
#else /* GHCI and TH is on */
thLocalId orig id id_ty th_bind_lvl
thLocalId orig id id_ty bind_lvl
= do { use_stage <- getStage -- TH case
; case use_stage of
Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
-> thBrackId orig id ps_var lie_var
other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
; return id }
}
; let use_lvl = thLevel use_stage
; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
; traceTc (text "thLocalId" <+> ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
; when (use_lvl > bind_lvl) $
checkCrossStageLifting orig id id_ty bind_lvl use_stage }
--------------------------------------
thBrackId orig id ps_var lie_var
checkCrossStageLifting :: InstOrigin -> Id -> TcType -> ThLevel -> ThStage -> TcM ()
-- We are inside brackets, and (use_lvl > bind_lvl)
-- Now we must check whether there's a cross-stage lift to do
-- Examples \x -> [| x |]
-- [| map |]
checkCrossStageLifting _ _ _ _ Comp = return ()
checkCrossStageLifting _ _ _ _ Splice = return ()
checkCrossStageLifting orig id id_ty bind_lvl (Brack _ ps_var lie_var)
| thTopLevelId id
= -- Top-level identifiers in this module,
-- (which have External Names)
......@@ -1146,9 +1158,10 @@ thBrackId orig id ps_var lie_var
-- But we do need to put f into the keep-alive
-- set, because after desugaring the code will
-- only mention f's *name*, not f itself.
do { keepAliveTc id; return id }
keepAliveTc id
| otherwise
| otherwise -- bind_lvl = outerLevel presumably,
-- but the Id is not bound at top level
= -- Nested identifiers, such as 'x' in
-- E.g. \x -> [| h x |]
-- We must behave as if the reference to x was
......@@ -1158,8 +1171,7 @@ thBrackId orig id ps_var lie_var
-- If 'x' occurs many times we may get many identical
-- bindings of the same splice proxy, but that doesn't
-- matter, although it's a mite untidy.
do { let id_ty = idType id
; checkTc (isTauTy id_ty) (polySpliceErr id)
do { checkTc (isTauTy id_ty) (polySpliceErr id)
-- If x is polymorphic, its occurrence sites might
-- have different instantiations, so we can't use plain
-- 'x' as the splice proxy name. I don't know how to
......@@ -1183,7 +1195,7 @@ thBrackId orig id ps_var lie_var
; ps <- readMutVar ps_var
; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
; return id }
; return () }
#endif /* GHCI */
\end{code}
......
......@@ -415,9 +415,11 @@ kc_hs_type ty@(HsRecTy _)
#ifdef GHCI /* Only if bootstrapped */
kc_hs_type (HsSpliceTy sp) = kcSpliceType sp
#else
kc_hs_type ty@(HsSpliceTy _) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
kc_hs_type ty@(HsSpliceTy {}) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
#endif
kc_hs_type (HsSpliceTyOut {}) = panic "kc_hs_type" -- Should not happen at all
-- remove the doc nodes here, no need to worry about the location since
-- its the same for a doc node and it's child type node
kc_hs_type (HsDocTy ty _)
......@@ -612,11 +614,15 @@ ds_type (HsForAllTy _ tv_names ctxt ty)
tau <- dsHsType ty
return (mkSigmaTy tyvars theta tau)
ds_type (HsSpliceTy {}) = panic "ds_type: HsSpliceTy"
ds_type (HsDocTy ty _) -- Remove the doc comment
= dsHsType ty
ds_type (HsSpliceTyOut kind)
= do { kind' <- zonkTcKindToKind kind
; newFlexiTyVarTy kind' }
ds_type (HsSpliceTy {}) = panic "ds_type"
dsHsTypes :: [LHsType Name] -> TcM [Type]
dsHsTypes arg_tys = mapM dsHsType arg_tys
\end{code}
......
......@@ -22,7 +22,7 @@ module TcRnTypes(
-- Template Haskell
ThStage(..), topStage, topAnnStage, topSpliceStage,
ThLevel, impLevel, topLevel,
ThLevel, impLevel, outerLevel, thLevel,
-- Arrows
ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
......@@ -382,37 +382,55 @@ pass it inwards.
-}
---------------------------
-- Template Haskell levels
-- Template Haskell stages and levels
---------------------------
data ThStage -- See Note [Template Haskell state diagram] in TcSplice
= Splice -- Top-level splicing
-- This code will be run *at compile time*;
-- the result replaces the splice
-- Binding level = 0
| Comp -- Ordinary Haskell code
-- Binding level = 1
| Brack -- Inside brackets
ThStage -- Binding level = level(stage) + 1
(TcRef [PendingSplice]) -- Accumulate pending splices here
(TcRef LIE) -- and type constraints here
topStage, topAnnStage, topSpliceStage :: ThStage
topStage = Comp
topAnnStage = Splice
topSpliceStage = Splice
instance Outputable ThStage where
ppr Splice = text "Splice"
ppr Comp = text "Comp"
ppr (Brack s _ _) = text "Brack" <> parens (ppr s)
type ThLevel = Int
-- Indicates how many levels of brackets we are inside
-- (always >= 0)
-- See Note [Template Haskell levels] in TcSplice
-- Incremented when going inside a bracket,
-- decremented when going inside a splice
-- NB: ThLevel is one greater than the 'n' in Fig 2 of the
-- original "Template meta-programming for Haskell" paper
impLevel, topLevel :: ThLevel
topLevel = 1 -- Things defined at top level of this module
impLevel, outerLevel :: ThLevel
impLevel = 0 -- Imported things; they can be used inside a top level splice
outerLevel = 1 -- Things defined outside brackets
-- NB: Things at level 0 are not *necessarily* imported.
-- eg $( \b -> ... ) here b is bound at level 0
--
-- For example:
-- f = ...
-- g1 = $(map ...) is OK
-- g2 = $(f ...) is not OK; because we havn't compiled f yet
data ThStage
= Comp ThLevel -- Ordinary compiling, usually at level topLevel but annotations use a lower level
| Splice ThLevel -- Inside a splice
| Brack ThLevel -- Inside brackets;
(TcRef [PendingSplice]) -- accumulate pending splices here
(TcRef LIE) -- and type constraints here
topStage, topAnnStage, topSpliceStage :: ThStage
topStage = Comp topLevel
topAnnStage = Comp (topLevel - 1)
topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level splice
thLevel :: ThStage -> ThLevel
thLevel Splice = 0
thLevel Comp = 1
thLevel (Brack s _ _) = thLevel s + 1
---------------------------
-- Arrow-notation context
......
......@@ -17,8 +17,6 @@ module TcSimplify (
tcSimplifyDeriv, tcSimplifyDefault,
bindInstsOfLocalFuns,
tcSimplifyStagedExpr,
misMatchMsg
) where
......@@ -3057,25 +3055,6 @@ tcSimplifyDefault theta = do
doc = ptext (sLit "default declaration")
\end{code}
@tcSimplifyStagedExpr@ performs a simplification but does so at a new
stage. This is used when typechecking annotations and splices.
\begin{code}
tcSimplifyStagedExpr :: ThStage -> TcM a -> TcM (a, TcDictBinds)
-- Type check an expression that runs at a top level stage as if
-- it were going to be spliced and then simplify it
tcSimplifyStagedExpr stage tc_action
= setStage stage $ do {
-- Typecheck the expression
(thing', lie) <- getLIE tc_action
-- Solve the constraints
; const_binds <- tcSimplifyTop lie
; return (thing', const_binds) }
\end{code}
%************************************************************************
......
This diff is collapsed.
......@@ -6065,12 +6065,11 @@ Wiki page</ulink>.
have type <literal>Q Exp</literal></para></listitem>
<listitem><para> an type; the spliced expression must
have type <literal>Q Typ</literal></para></listitem>
<listitem><para> a list of top-level declarations; the spliced expression must have type <literal>Q [Dec]</literal></para></listitem>
<listitem><para> a list of top-level declarations; the spliced expression
must have type <literal>Q [Dec]</literal></para></listitem>
</itemizedlist>
</para>
Inside a splice you can can only call functions defined in imported modules,
not functions defined elsewhere in the same module.</listitem>
not functions defined elsewhere in the same module.</para></listitem>
<listitem><para>
A expression quotation is written in Oxford brackets, thus:
......@@ -6087,7 +6086,7 @@ Wiki page</ulink>.
A quasi-quotation can appear in either a pattern context or an
expression context and is also written in Oxford brackets:
<itemizedlist>
<listitem><para> <literal>[:<replaceable>varid</replaceable>| ... |]</literal>,
<listitem><para> <literal>[$<replaceable>varid</replaceable>| ... |]</literal>,
where the "..." is an arbitrary string; a full description of the
quasi-quotation facility is given in <xref linkend="th-quasiquotation"/>.</para></listitem>
</itemizedlist></para></listitem>
......@@ -6108,6 +6107,25 @@ Wiki page</ulink>.
</para>
</listitem>
<listitem><para> You may omit the <literal>$(...)</literal> in a top-level declaration splice.
Simply writing an expression (rather than a declaration) implies a splice. For example, you can write
<programlisting>
module Foo where
import Bar
f x = x
$(deriveStuff 'f) -- Uses the $(...) notation
g y = y+1
deriveStuff 'g -- Omits the $(...)
h z = z-1
</programlisting>
This abbreviation makes top-level declaration slices quieter and less intimidating.
</para></listitem>
</itemizedlist>
(Compared to the original paper, there are many differences of detail.
......
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