TcSplice: Template Haskell splices
+
\begin{code}
{-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-}
-- The above warning supression flag is a temporary kludge.
module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
lookupThName_maybe,
-todoSession, todoTcM,
runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
#include "HsVersions.h"
import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
import System.IO.Error
-
-
---here for every bad reason :-)
-import InstEnv
-import FamInstEnv
---Session
-todoSession :: HscEnv -> Name -> IO (Messages, Maybe (LHsDecl RdrName))
-todoSession hsc_env name
- = initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext hsc_env (hsc_IC hsc_env) $
- todoTcM name
-
-
-todoTcM :: Name -> TcM (LHsDecl RdrName)
-todoTcM name = do
- tcTyThing <- TcEnv.tcLookup name
- thInfo <- TcSplice.reifyThing tcTyThing
- let Just thDec = thGetDecFromInfo thInfo --BUG!
- let Right [hsdecl] = Convert.convertToHsDecls
- (error "srcspan of different package?")
- [thDec]
- return hsdecl
-
-thGetDecFromInfo :: TH.Info -> Maybe TH.Dec
-thGetDecFromInfo (TH.ClassI dec) = Just dec
-thGetDecFromInfo (TH.ClassOpI {}) = error "classop"
-thGetDecFromInfo (TH.TyConI dec) = Just dec
-thGetDecFromInfo (TH.PrimTyConI {}) = Nothing --error "sometimes we can invent a signature? or it's better not to?"
-thGetDecFromInfo (TH.DataConI {}) = error "datacon"
-thGetDecFromInfo (TH.VarI _name _type (Just dec) _fixity) = Just dec
-thGetDecFromInfo (TH.VarI _name _type Nothing _fixity) = error "vari"
-thGetDecFromInfo (TH.TyVarI {}) = Nothing --tyvars don't have decls? they kinda have a type though...
-
-setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
-setInteractiveContext hsc_env icxt thing_inside
- = let -- Initialise the tcg_inst_env with instances from all home modules.
- -- This mimics the more selective call to hptInstances in tcRnModule.
- (home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True)
- in
- updGblEnv (\env -> env {
- tcg_rdr_env = ic_rn_gbl_env icxt,
- tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts,
- tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env)
- home_fam_insts
- }) $
-
- tcExtendGhciEnv (ic_tmp_ids icxt) $
- -- tcExtendGhciEnv does lots:
- -- - it extends the local type env (tcl_env) with the given Ids,
- -- - it extends the local rdr env (tcl_rdr) with the Names from
- -- the given Ids
- -- - it adds the free tyvars of the Ids to the tcl_tyvars
- -- set.
- --
- -- later ids in ic_tmp_ids must shadow earlier ones with the same
- -- OccName, and tcExtendIdEnv implements this behaviour.
-
- do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
- ; thing_inside }
\end{code}
+Note [How top-level splices are handled]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Top-level splices (those not inside a [| .. |] quotation bracket) are handled
+very straightforwardly:
+
+ 1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
+
+ 2. runMetaT: desugar, compile, run it, and convert result back to
+ HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,
+ HsExpr RdrName etc)
+
+ 3. treat the result as if that's what you saw in the first place
+ e.g for HsType, rename and kind-check
+ for HsExpr, rename and type-check
+
+ (The last step is different for decls, becuase they can *only* be
+ top-level: we return the result of step 2.)
+
+Note [How brackets and nested splices are handled]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Nested splices (those inside a [| .. |] quotation bracket), are treated
+quite differently.
+
+ * After typechecking, the bracket [| |] carries
+
+ a) A mutable list of PendingSplice
+ type PendingSplice = (Name, LHsExpr Id)
+
+ b) The quoted expression e, *renamed*: (HsExpr Name)
+ The expression e has been typechecked, but the result of
+ that typechecking is discarded.
+
+ * The brakcet is desugared by DsMeta.dsBracket. It
+
+ a) Extends the ds_meta environment with the PendingSplices
+ attached to the bracket
+
+ b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
+ run, will produce a suitable TH expression/type/decl. This
+ is why we leave the *renamed* expression attached to the bracket:
+ the quoted expression should not be decorated with all the goop
+ added by the type checker
+
+ * Each splice carries a unique Name, called a "splice point", thus
+ ${n}(e). The name is initialised to an (Unqual "splice") when the
+ splice is created; the renamer gives it a unique.
+
+ * When the type checker type-checks a nested splice ${n}(e), it
+ - typechecks e
+ - adds the typechecked expression (of type (HsExpr Id))
+ as a pending splice to the enclosing bracket
+ - returns something non-committal
+ Eg for [| f ${n}(g x) |], the typechecker
+ - attaches the typechecked term (g x) to the pending splices for n
+ in the outer bracket
+ - returns a non-committal type \alpha.
+ Remember that the bracket discards the typechecked term altogether
+
+ * When DsMeta (used to desugar the body of the bracket) comes across
+ a splice, it looks up the splice's Name, n, in the ds_meta envt,
+ to find an (HsExpr Id) that should be substituted for the splice;
+ it just desugars it to get a CoreExpr (DsMeta.repSplice).
+
+Example:
+ Source: f = [| Just $(g 3) |]
+ The [| |] part is a HsBracket
+
+ Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
+ The [| |] part is a HsBracketOut, containing *renamed*
+ (not typechecked) expression
+ The "s7" is the "splice point"; the (g Int 3) part
+ is a typechecked expression
+
+ Desugared: f = do { s7 <- g Int 3
+ ; return (ConE "Data.Maybe.Just" s7) }
+
+
+Note [Template Haskell state diagram]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here are the ThStages, s, their corresponding level numbers
+(the result of (thLevel s)), and their state transitions.
+
+ ----------- $ ------------ $
+ | Comp | ---------> | Splice | -----|
+ | 1 | | 0 | <----|
+ ----------- ------------
+ ^ | ^ |
+ $ | | [||] $ | | [||]
+ | v | v
+ -------------- ----------------
+ | Brack Comp | | Brack Splice |
+ | 2 | | 1 |
+ -------------- ----------------
+
+* Normal top-level declarations start in state Comp
+ (which has level 1).
+ Annotations start in state Splice, since they are
+ treated very like a splice (only without a '$')
+
+* Code compiled in state Splice (and only such code)
+ will be *run at compile time*, with the result replacing
+ the splice
+
+* The original paper used level -1 instead of 0, etc.
+
+* The original paper did not allow a splice within a
+ splice, but there is no reason not to. This is the
+ $ transition in the top right.
+
Note [Template Haskell levels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Imported things are impLevel (= 0)
* Variables are bound at the "current level"
-* The current level starts off at topLevel (= 1)
+* The current level starts off at outerLevel (= 1)
* The level is decremented by splicing $(..)
incremented by brackets [| |]
%* *
%************************************************************************
-Note [Handling brackets]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Source: f = [| Just $(g 3) |]
- The [| |] part is a HsBracket
-
-Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
- The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
- The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
-
-Desugared: f = do { s7 <- g Int 3
- ; return (ConE "Data.Maybe.Just" s7) }
\begin{code}
+-- See Note [How brackets and nested splices are handled]
tcBracket brack res_ty
= addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
2 (ppr brack)) $
- do { level <- getStage
- ; case bracketOK level of {
- Nothing -> failWithTc (illegalBracket level) ;
- Just next_level -> do {
+ do { -- Check for nested brackets
+ cur_stage <- getStage
+ ; checkTc (not (isBrackStage cur_stage)) illegalBracket
+
+ -- Brackets are desugared to code that mentions the TH package
+ ; recordThUse
-- Typecheck expr to make sure it is valid,
-- but throw away the results. We'll type check
-- it again when we actually use it.
- recordThUse
; pending_splices <- newMutVar []
; lie_var <- getLIEVar
- ; (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
- (getLIE (tc_bracket next_level brack))
+ ; (meta_ty, lie) <- setStage (Brack cur_stage pending_splices lie_var)
+ (getLIE (tc_bracket cur_stage brack))
; tcSimplifyBracket lie
-- Make the expected type have the right shape
-- Return the original expression, not the type-decorated one
; pendings <- readMutVar pending_splices
- ; return (noLoc (HsBracketOut brack pendings)) }}}
+ ; return (noLoc (HsBracketOut brack pendings)) }
-tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
-tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
+tc_bracket :: ThStage -> HsBracket Name -> TcM TcType
+tc_bracket outer_stage (VarBr name) -- Note [Quoting names]
= do { thing <- tcLookup name
; case thing of
AGlobal _ -> return ()
ATcId { tct_level = bind_lvl, tct_id = id }
- | thTopLevelId id -- C.f thTopLevelId case of
- -> keepAliveTc id -- TcExpr.thBrackId
+ | thTopLevelId id -- C.f TcExpr.checkCrossStageLifting
+ -> keepAliveTc id
| otherwise
- -> do { checkTc (use_lvl == bind_lvl)
+ -> do { checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr name) }
_ -> pprPanic "th_bracket" (ppr name)
\begin{code}
tcSpliceExpr (HsSplice name expr) res_ty
= setSrcSpan (getLoc expr) $ do
- level <- getStage
- case spliceOK level of {
- Nothing -> failWithTc (illegalSplice level) ;
- Just next_level ->
+ { stage <- getStage
+ ; case stage of {
+ Splice -> tcTopSplice expr res_ty ;
+ Comp -> tcTopSplice expr res_ty ;
- case level of {
- Comp _ -> do { e <- tcTopSplice expr res_ty
- ; return (unLoc e) } ;
- Brack _ ps_var lie_var -> do
+ Brack pop_stage ps_var lie_var -> do
+ -- See Note [How brackets and nested splices are handled]
-- A splice inside brackets
-- NB: ignore res_ty, apart from zapping it to a mono-type
-- e.g. [| reverse $(h 4) |]
-- Here (h 4) :: Q Exp
-- but $(h 4) :: forall a.a i.e. anything!
- _ <- unBox res_ty
- meta_exp_ty <- tcMetaTy expQTyConName
- expr' <- setStage (Splice next_level) (
- setLIEVar lie_var $
- tcMonoExpr expr meta_exp_ty
- )
+ { _ <- unBox res_ty
+ ; meta_exp_ty <- tcMetaTy expQTyConName
+ ; expr' <- setStage pop_stage $
+ setLIEVar lie_var $
+ tcMonoExpr expr meta_exp_ty
-- Write the pending splice into the bucket
- ps <- readMutVar ps_var
- writeMutVar ps_var ((name,expr') : ps)
+ ; ps <- readMutVar ps_var
+ ; writeMutVar ps_var ((name,expr') : ps)
- return (panic "tcSpliceExpr") -- The returned expression is ignored
+ ; return (panic "tcSpliceExpr") -- The returned expression is ignored
+ }}}
- ; Splice {} -> panic "tcSpliceExpr Splice"
- }}
-
--- tcTopSplice used to have this:
--- Note that we do not decrement the level (to -1) before
--- typechecking the expression. For example:
--- f x = $( ...$(g 3) ... )
--- The recursive call to tcMonoExpr will simply expand the
--- inner escape before dealing with the outer one
-
-tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
-tcTopSplice expr res_ty = do
- meta_exp_ty <- tcMetaTy expQTyConName
+tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (HsExpr Id)
+-- Note [How top-level splices are handled]
+tcTopSplice expr res_ty
+ = do { meta_exp_ty <- tcMetaTy expQTyConName
-- Typecheck the expression
- zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
+ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
-- Run the expression
- traceTc (text "About to run" <+> ppr zonked_q_expr)
- expr2 <- runMetaE convertToHsExpr zonked_q_expr
-
- traceTc (text "Got result" <+> ppr expr2)
-
- showSplice "expression" expr (ppr expr2)
+ ; expr2 <- runMetaE zonked_q_expr
+ ; showSplice "expression" expr (ppr expr2)
-- Rename it, but bale out if there are errors
-- otherwise the type checker just gives more spurious errors
- (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
+ ; addErrCtxt (spliceResultDoc expr) $ do
+ { (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
- tcMonoExpr exp3 res_ty
+ ; exp4 <- tcMonoExpr exp3 res_ty
+ ; return (unLoc exp4) } }
+spliceResultDoc :: LHsExpr Name -> SDoc
+spliceResultDoc expr
+ = sep [ ptext (sLit "In the result of the splice:")
+ , nest 2 (char '$' <> pprParendExpr expr)
+ , ptext (sLit "To see what the splice expanded to, use -ddump-splices")]
-tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
+-------------------
+tcTopSpliceExpr :: TcM (LHsExpr Id) -> TcM (LHsExpr Id)
+-- Note [How top-level splices are handled]
-- Type check an expression that is the body of a top-level splice
-- (the caller will compile and run it)
-tcTopSpliceExpr expr meta_ty
+-- Note that set the level to Splice, regardless of the original level,
+-- before typechecking the expression. For example:
+-- f x = $( ...$(g 3) ... )
+-- The recursive call to tcMonoExpr will simply expand the
+-- inner escape before dealing with the outer one
+
+tcTopSpliceExpr tc_action
= checkNoErrs $ -- checkNoErrs: must not try to run the thing
-- if the type checker fails!
- do { (expr', const_binds) <- tcSimplifyStagedExpr topSpliceStage $
- (recordThUse >> tcMonoExpr expr meta_ty)
+ setStage Splice $
+ do { -- Typecheck the expression
+ (expr', lie) <- getLIE tc_action
+
+ -- Solve the constraints
+ ; const_binds <- tcSimplifyTop lie
+
-- Zonk it and tie the knot of dictionary bindings
; zonkTopLExpr (mkHsDictLet const_binds expr') }
\end{code}
%************************************************************************
%* *
+ Splicing a type
+%* *
+%************************************************************************
+
+Very like splicing an expression, but we don't yet share code.
+
+\begin{code}
+kcSpliceType (HsSplice name hs_expr)
+ = setSrcSpan (getLoc hs_expr) $ do
+ { stage <- getStage
+ ; case stage of {
+ Splice -> kcTopSpliceType hs_expr ;
+ Comp -> kcTopSpliceType hs_expr ;
+
+ Brack pop_level ps_var lie_var -> do
+ -- See Note [How brackets and nested splices are handled]
+ -- A splice inside brackets
+ { meta_ty <- tcMetaTy typeQTyConName
+ ; expr' <- setStage pop_level $
+ setLIEVar lie_var $
+ tcMonoExpr hs_expr meta_ty
+
+ -- Write the pending splice into the bucket
+ ; ps <- readMutVar ps_var
+ ; writeMutVar ps_var ((name,expr') : ps)
+
+ -- e.g. [| f (g :: Int -> $(h 4)) |]
+ -- Here (h 4) :: Q Type
+ -- but $(h 4) :: a i.e. any type, of any kind
+
+ -- We return a HsSpliceTyOut, which serves to convey the kind to
+ -- the ensuing TcHsType.dsHsType, which makes up a non-committal
+ -- type variable of a suitable kind
+ ; kind <- newKindVar
+ ; return (HsSpliceTyOut kind, kind)
+ }}}
+
+kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
+-- Note [How top-level splices are handled]
+kcTopSpliceType expr
+ = do { meta_ty <- tcMetaTy typeQTyConName
+
+ -- Typecheck the expression
+ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_ty)
+
+ -- Run the expression
+ ; hs_ty2 <- runMetaT zonked_q_expr
+ ; showSplice "type" expr (ppr hs_ty2)
+
+ -- Rename it, but bale out if there are errors
+ -- otherwise the type checker just gives more spurious errors
+ ; addErrCtxt (spliceResultDoc expr) $ do
+ { let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
+ ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
+ ; (ty4, kind) <- kcLHsType hs_ty3
+ ; return (unLoc ty4, kind) }}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Splicing an expression}
+%* *
+%************************************************************************
+
+\begin{code}
+-- Note [How top-level splices are handled]
+-- Always at top level
+-- Type sig at top of file:
+-- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
+tcSpliceDecls expr
+ = do { meta_dec_ty <- tcMetaTy decTyConName
+ ; meta_q_ty <- tcMetaTy qTyConName
+ ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
+ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr list_q)
+
+ -- Run the expression
+ ; decls <- runMetaD zonked_q_expr
+ ; showSplice "declarations" expr
+ (ppr (getLoc expr) $$ (vcat (map ppr decls)))
+
+ ; return decls }
+\end{code}
+
+
+%************************************************************************
+%* *
Annotations
%* *
%************************************************************************
\begin{code}
runAnnotation target expr = do
- expr_ty <- newFlexiTyVarTy liftedTypeKind
-
-- Find the classes we want instances for in order to call toAnnotationWrapper
+ loc <- getSrcSpanM
data_class <- tcLookupClass dataClassName
+ to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
-- Check the instances we require live in another module (we want to execute it..)
-- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
-- also resolves the LIE constraints to detect e.g. instance ambiguity
- ((wrapper, expr'), const_binds) <- tcSimplifyStagedExpr topAnnStage $ do
- expr' <- tcPolyExprNC expr expr_ty
+ zonked_wrapped_expr' <- tcTopSpliceExpr $
+ do { (expr', expr_ty) <- tcInferRhoNC expr
+ -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
-- By instantiating the call >here< it gets registered in the
- -- LIE consulted by tcSimplifyStagedExpr
+ -- LIE consulted by tcTopSpliceExpr
-- and hence ensures the appropriate dictionary is bound by const_binds
- wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
- return (wrapper, expr')
-
- -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
- loc <- getSrcSpanM
- to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
- let specialised_to_annotation_wrapper_expr = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
- wrapped_expr' = mkHsDictLet const_binds $
- L loc (HsApp specialised_to_annotation_wrapper_expr expr')
-
- -- If we have type checking problems then potentially zonking
- -- (and certainly compilation) may fail. Give up NOW!
- failIfErrsM
-
- -- Zonk the type variables out of that raw expression. Note that
- -- in particular we don't call recordThUse, since we don't
- -- necessarily use any code or definitions from that package.
- zonked_wrapped_expr' <- zonkTopLExpr wrapped_expr'
+ ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
+ ; let specialised_to_annotation_wrapper_expr
+ = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
+ ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
-- Run the appropriately wrapped expression to get the value of
-- the annotation and its dictionaries. The return value is of
runQuasiQuote :: Outputable hs_syn
=> HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
-> Name -- Of type QuasiQuoter -> String -> Q th_syn
- -> String -- Documentation string only
-> Name -- Name of th_syn type
- -> (SrcSpan -> th_syn -> Either Message hs_syn)
+ -> MetaOps th_syn hs_syn
-> TcM hs_syn
-runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
+runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector meta_ty meta_ops
= do { -- Check that the quoter is not locally defined, otherwise the TH
-- machinery will not be able to run the quasiquote.
; this_mod <- getModule
; let expr = L q_span $
HsApp (L q_span $
HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
- ; recordThUse
; meta_exp_ty <- tcMetaTy meta_ty
-- Typecheck the expression
- ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
+ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
-- Run the expression
- ; traceTc (text "About to run" <+> ppr zonked_q_expr)
- ; result <- runMetaQ convert zonked_q_expr
- ; traceTc (text "Got result" <+> ppr result)
- ; showSplice desc quoteExpr (ppr result)
- ; return result
- }
+ ; result <- runMetaQ meta_ops zonked_q_expr
+ ; showSplice (mt_desc meta_ops) quoteExpr (ppr result)
-runQuasiQuoteExpr quasiquote
- = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
+ ; return result }
-runQuasiQuotePat quasiquote
- = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
+runQuasiQuoteExpr quasiquote = runQuasiQuote quasiquote quoteExpName expQTyConName exprMetaOps
+runQuasiQuotePat quasiquote = runQuasiQuote quasiquote quotePatName patQTyConName patMetaOps
quoteStageError :: Name -> SDoc
quoteStageError quoter
%************************************************************************
%* *
- Splicing a type
+\subsection{Running an expression}
%* *
%************************************************************************
-Very like splicing an expression, but we don't yet share code.
-
\begin{code}
-kcSpliceType (HsSplice name hs_expr)
- = setSrcSpan (getLoc hs_expr) $ do
- { level <- getStage
- ; case spliceOK level of {
- Nothing -> failWithTc (illegalSplice level) ;
- Just next_level -> do
-
- { case level of {
- Comp _ -> do { (t,k) <- kcTopSpliceType hs_expr
- ; return (unLoc t, k) } ;
- Brack _ ps_var lie_var -> do
-
- { -- A splice inside brackets
- ; meta_ty <- tcMetaTy typeQTyConName
- ; expr' <- setStage (Splice next_level) $
- setLIEVar lie_var $
- tcMonoExpr hs_expr meta_ty
-
- -- Write the pending splice into the bucket
- ; ps <- readMutVar ps_var
- ; writeMutVar ps_var ((name,expr') : ps)
-
- -- e.g. [| Int -> $(h 4) |]
- -- Here (h 4) :: Q Type
- -- but $(h 4) :: forall a.a i.e. any kind
- ; kind <- newKindVar
- ; return (panic "kcSpliceType", kind) -- The returned type is ignored
+data MetaOps th_syn hs_syn
+ = MT { mt_desc :: String -- Type of beast (expression, type etc)
+ , mt_show :: th_syn -> String -- How to show the th_syn thing
+ , mt_cvt :: SrcSpan -> th_syn -> Either Message hs_syn
+ -- How to convert to hs_syn
}
- ; Splice {} -> panic "kcSpliceType Splice"
- }}}}
-
-kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
-kcTopSpliceType expr
- = do { meta_ty <- tcMetaTy typeQTyConName
-
- -- Typecheck the expression
- ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
-
- -- Run the expression
- ; traceTc (text "About to run" <+> ppr zonked_q_expr)
- ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
-
- ; traceTc (text "Got result" <+> ppr hs_ty2)
-
- ; showSplice "type" expr (ppr hs_ty2)
-
- -- Rename it, but bale out if there are errors
- -- otherwise the type checker just gives more spurious errors
- ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
- ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
-
- ; kcLHsType hs_ty3 }
-\end{code}
-%************************************************************************
-%* *
-\subsection{Splicing an expression}
-%* *
-%************************************************************************
-
-\begin{code}
--- Always at top level
--- Type sig at top of file:
--- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
-tcSpliceDecls expr
- = do { meta_dec_ty <- tcMetaTy decTyConName
- ; meta_q_ty <- tcMetaTy qTyConName
- ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
- ; zonked_q_expr <- tcTopSpliceExpr expr list_q
-
- -- Run the expression
- ; traceTc (text "About to run" <+> ppr zonked_q_expr)
- ; decls <- runMetaD convertToHsDecls zonked_q_expr
+exprMetaOps :: MetaOps TH.Exp (LHsExpr RdrName)
+exprMetaOps = MT { mt_desc = "expression", mt_show = TH.pprint, mt_cvt = convertToHsExpr }
- ; traceTc (text "Got result" <+> vcat (map ppr decls))
- ; showSplice "declarations"
- expr
- (ppr (getLoc expr) $$ (vcat (map ppr decls)))
- ; return decls }
-\end{code}
+patMetaOps :: MetaOps TH.Pat (LPat RdrName)
+patMetaOps = MT { mt_desc = "pattern", mt_show = TH.pprint, mt_cvt = convertToPat }
+typeMetaOps :: MetaOps TH.Type (LHsType RdrName)
+typeMetaOps = MT { mt_desc = "type", mt_show = TH.pprint, mt_cvt = convertToHsType }
-%************************************************************************
-%* *
-\subsection{Running an expression}
-%* *
-%************************************************************************
+declMetaOps :: MetaOps [TH.Dec] [LHsDecl RdrName]
+declMetaOps = MT { mt_desc = "declarations", mt_show = TH.pprint, mt_cvt = convertToHsDecls }
-\begin{code}
-runMetaAW :: (AnnotationWrapper -> output)
+----------------
+runMetaAW :: Outputable output
+ => (AnnotationWrapper -> output)
-> LHsExpr Id -- Of type AnnotationWrapper
-> TcM output
runMetaAW k = runMeta False (\_ -> return . Right . k)
-- We turn off showing the code in meta-level exceptions because doing so exposes
-- the toAnnotationWrapper function that we slap around the users code
-runQThen :: (SrcSpan -> input -> Either Message output)
- -> SrcSpan
- -> TH.Q input
- -> TcM (Either Message output)
-runQThen f expr_span what = TH.runQ what >>= (return . f expr_span)
-
-runMetaQ :: (SrcSpan -> input -> Either Message output)
+-----------------
+runMetaQ :: Outputable hs_syn
+ => MetaOps th_syn hs_syn
-> LHsExpr Id
- -> TcM output
-runMetaQ = runMeta True . runQThen
+ -> TcM hs_syn
+runMetaQ (MT { mt_show = show_th, mt_cvt = cvt }) expr
+ = runMeta True run_and_cvt expr
+ where
+ run_and_cvt expr_span hval
+ = do { th_result <- TH.runQ hval
+ ; traceTc (text "Got TH result:" <+> text (show_th th_result))
+ ; return (cvt expr_span th_result) }
-runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
- -> LHsExpr Id -- Of type (Q Exp)
+runMetaE :: LHsExpr Id -- Of type (Q Exp)
-> TcM (LHsExpr RdrName)
-runMetaE = runMetaQ
-
-runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
- -> LHsExpr Id -- Of type (Q Pat)
- -> TcM (Pat RdrName)
-runMetaP = runMetaQ
+runMetaE = runMetaQ exprMetaOps
-runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
- -> LHsExpr Id -- Of type (Q Type)
+runMetaT :: LHsExpr Id -- Of type (Q Type)
-> TcM (LHsType RdrName)
-runMetaT = runMetaQ
+runMetaT = runMetaQ typeMetaOps
-runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
- -> LHsExpr Id -- Of type Q [Dec]
+runMetaD :: LHsExpr Id -- Of type Q [Dec]
-> TcM [LHsDecl RdrName]
-runMetaD = runMetaQ
-
-runMeta :: Bool -- Whether code should be printed in the exception message
- -> (SrcSpan -> input -> TcM (Either Message output))
- -> LHsExpr Id -- Of type X
- -> TcM output -- Of type t
+runMetaD = runMetaQ declMetaOps
+
+---------------
+runMeta :: (Outputable hs_syn)
+ => Bool -- Whether code should be printed in the exception message
+ -> (SrcSpan -> x -> TcM (Either Message hs_syn)) -- How to run x
+ -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that
+ -> TcM hs_syn -- Of type t
runMeta show_code run_and_convert expr
- = do { -- Desugar
- ds_expr <- initDsTc (dsLExpr expr)
+ = do { traceTc (text "About to run" <+> ppr expr)
+
+ -- Desugar
+ ; ds_expr <- initDsTc (dsLExpr expr)
-- Compile and link it; might fail if linking fails
; hsc_env <- getTopEnv
; src_span <- getSrcSpanM
do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
; case mb_result of
Left err -> failWithTc err
- Right result -> return $! result }
+ Right result -> do { traceTc (ptext (sLit "Got HsSyn result:") <+> ppr result)
+ ; return $! result } }
; case either_tval of
Right v -> return v
- Left se ->
- case fromException se of
- Just IOEnvFailure ->
- failM -- Error already in Tc monad
- _ -> failWithTc (mk_msg "run" se) -- Exception
+ Left se -> case fromException se of
+ Just IOEnvFailure -> failM -- Error already in Tc monad
+ _ -> failWithTc (mk_msg "run" se) -- Exception
}}}
where
mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
; return (TH.mkNameU s i) }
qReport True msg = addErr (text msg)
- qReport False msg = addReport (text msg)
+ qReport False msg = addReport (text msg) empty
qLocation = do { m <- getModule
; l <- getSrcSpanM
text "======>",
nest 2 after])]) }
-illegalBracket :: ThStage -> SDoc
-illegalBracket level
- = ptext (sLit "Illegal bracket at level") <+> ppr level
-
-illegalSplice :: ThStage -> SDoc
-illegalSplice level
- = ptext (sLit "Illegal splice at level") <+> ppr level
-
+illegalBracket :: SDoc
+illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
#endif /* GHCI */
\end{code}
; fix <- reifyFixity (idName id)
; let v = reifyName id
; case idDetails id of
- ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
- _ -> return (TH.VarI v ty Nothing fix)
+ ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
+ _ -> return (TH.VarI v ty Nothing fix)
}
reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc