2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcSplice: Template Haskell splices
10 {-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-}
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and fix
13 -- any warnings in the module. See
14 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
20 runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
22 #include "HsVersions.h"
26 -- These imports are the reason that TcSplice
27 -- is very high up the module hierarchy
63 import DsMonad hiding (Splice)
75 import qualified Language.Haskell.TH as TH
76 -- THSyntax gives access to internal functions and data types
77 import qualified Language.Haskell.TH.Syntax as TH
80 -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
81 import GHC.Desugar ( AnnotationWrapper(..) )
84 import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
85 import System.IO.Error
88 --here for every bad reason :-)
92 todoSession :: HscEnv -> Name -> IO (Messages, Maybe (LHsDecl RdrName))
93 todoSession hsc_env name
94 = initTcPrintErrors hsc_env iNTERACTIVE $
95 setInteractiveContext hsc_env (hsc_IC hsc_env) $
99 todoTcM :: Name -> TcM (LHsDecl RdrName)
101 tcTyThing <- TcEnv.tcLookup name
102 thInfo <- TcSplice.reifyThing tcTyThing
103 let Just thDec = thGetDecFromInfo thInfo --BUG!
104 let Right [hsdecl] = Convert.convertToHsDecls
105 (error "srcspan of different package?")
109 thGetDecFromInfo :: TH.Info -> Maybe TH.Dec
110 thGetDecFromInfo (TH.ClassI dec) = Just dec
111 thGetDecFromInfo (TH.ClassOpI {}) = error "classop"
112 thGetDecFromInfo (TH.TyConI dec) = Just dec
113 thGetDecFromInfo (TH.PrimTyConI {}) = Nothing --error "sometimes we can invent a signature? or it's better not to?"
114 thGetDecFromInfo (TH.DataConI {}) = error "datacon"
115 thGetDecFromInfo (TH.VarI _name _type (Just dec) _fixity) = Just dec
116 thGetDecFromInfo (TH.VarI _name _type Nothing _fixity) = error "vari"
117 thGetDecFromInfo (TH.TyVarI {}) = Nothing --tyvars don't have decls? they kinda have a type though...
119 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
120 setInteractiveContext hsc_env icxt thing_inside
121 = let -- Initialise the tcg_inst_env with instances from all home modules.
122 -- This mimics the more selective call to hptInstances in tcRnModule.
123 (home_insts, home_fam_insts) = hptInstances hsc_env (\_mod -> True)
125 updGblEnv (\env -> env {
126 tcg_rdr_env = ic_rn_gbl_env icxt,
127 tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts,
128 tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env)
132 tcExtendGhciEnv (ic_tmp_ids icxt) $
133 -- tcExtendGhciEnv does lots:
134 -- - it extends the local type env (tcl_env) with the given Ids,
135 -- - it extends the local rdr env (tcl_rdr) with the Names from
137 -- - it adds the free tyvars of the Ids to the tcl_tyvars
140 -- later ids in ic_tmp_ids must shadow earlier ones with the same
141 -- OccName, and tcExtendIdEnv implements this behaviour.
143 do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
147 Note [How top-level splices are handled]
148 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
149 Top-level splices (those not inside a [| .. |] quotation bracket) are handled
150 very straightforwardly:
152 1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
154 2. runMetaT: desugar, compile, run it, and convert result back to
155 HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,
158 3. treat the result as if that's what you saw in the first place
159 e.g for HsType, rename and kind-check
160 for HsExpr, rename and type-check
162 (The last step is different for decls, becuase they can *only* be
163 top-level: we return the result of step 2.)
165 Note [How brackets and nested splices are handled]
166 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
167 Nested splices (those inside a [| .. |] quotation bracket), are treated
170 * After typechecking, the bracket [| |] carries
172 a) A mutable list of PendingSplice
173 type PendingSplice = (Name, LHsExpr Id)
175 b) The quoted expression e, *renamed*: (HsExpr Name)
176 The expression e has been typechecked, but the result of
177 that typechecking is discarded.
179 * The brakcet is desugared by DsMeta.dsBracket. It
181 a) Extends the ds_meta environment with the PendingSplices
182 attached to the bracket
184 b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
185 run, will produce a suitable TH expression/type/decl. This
186 is why we leave the *renamed* expression attached to the bracket:
187 the quoted expression should not be decorated with all the goop
188 added by the type checker
190 * Each splice carries a unique Name, called a "splice point", thus
191 ${n}(e). The name is initialised to an (Unqual "splice") when the
192 splice is created; the renamer gives it a unique.
194 * When the type checker type-checks a nested splice ${n}(e), it
196 - adds the typechecked expression (of type (HsExpr Id))
197 as a pending splice to the enclosing bracket
198 - returns something non-committal
199 Eg for [| f ${n}(g x) |], the typechecker
200 - attaches the typechecked term (g x) to the pending splices for n
202 - returns a non-committal type \alpha.
203 Remember that the bracket discards the typechecked term altogether
205 * When DsMeta (used to desugar the body of the bracket) comes across
206 a splice, it looks up the splice's Name, n, in the ds_meta envt,
207 to find an (HsExpr Id) that should be substituted for the splice;
208 it just desugars it to get a CoreExpr (DsMeta.repSplice).
211 Source: f = [| Just $(g 3) |]
212 The [| |] part is a HsBracket
214 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
215 The [| |] part is a HsBracketOut, containing *renamed*
216 (not typechecked) expression
217 The "s7" is the "splice point"; the (g Int 3) part
218 is a typechecked expression
220 Desugared: f = do { s7 <- g Int 3
221 ; return (ConE "Data.Maybe.Just" s7) }
224 Note [Template Haskell state diagram]
225 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
226 Here are the ThStages, s, their corresponding level numbers
227 (the result of (thLevel s)), and their state transitions.
229 ----------- $ ------------ $
230 | Comp | ---------> | Splice | -----|
232 ----------- ------------
234 $ | | [||] $ | | [||]
236 -------------- ----------------
237 | Brack Comp | | Brack Splice |
239 -------------- ----------------
241 * Normal top-level declarations start in state Comp
243 Annotations start in state Splice, since they are
244 treated very like a splice (only without a '$')
246 * Code compiled in state Splice (and only such code)
247 will be *run at compile time*, with the result replacing
250 * The original paper used level -1 instead of 0, etc.
252 * The original paper did not allow a splice within a
253 splice, but there is no reason not to. This is the
254 $ transition in the top right.
256 Note [Template Haskell levels]
257 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
258 * Imported things are impLevel (= 0)
260 * In GHCi, variables bound by a previous command are treated
261 as impLevel, because we have bytecode for them.
263 * Variables are bound at the "current level"
265 * The current level starts off at outerLevel (= 1)
267 * The level is decremented by splicing $(..)
268 incremented by brackets [| |]
269 incremented by name-quoting 'f
271 When a variable is used, we compare
272 bind: binding level, and
273 use: current level at usage site
276 bind > use Always error (bound later than used)
279 bind = use Always OK (bound same stage as used)
280 [| \x -> $(f [| x |]) |]
282 bind < use Inside brackets, it depends
286 For (bind < use) inside brackets, there are three cases:
287 - Imported things OK f = [| map |]
288 - Top-level things OK g = [| f |]
289 - Non-top-level Only if there is a liftable instance
290 h = \(x:Int) -> [| x |]
292 See Note [What is a top-level Id?]
296 A quoted name 'n is a bit like a quoted expression [| n |], except that we
297 have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
298 the use-level to account for the brackets, the cases are:
307 See Note [What is a top-level Id?] in TcEnv. Examples:
309 f 'map -- OK; also for top-level defns of this module
311 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
312 -- cross-stage lifting
314 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
316 [| \x. $(f 'x) |] -- OK
319 Note [What is a top-level Id?]
320 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
321 In the level-control criteria above, we need to know what a "top level Id" is.
322 There are three kinds:
323 * Imported from another module (GlobalId, ExternalName)
324 * Bound at the top level of this module (ExternalName)
325 * In GHCi, bound by a previous stmt (GlobalId)
326 It's strange that there is no one criterion tht picks out all three, but that's
327 how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids
328 bound in an earlier Stmt, but what module would you choose? See
329 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
331 The predicate we use is TcEnv.thTopLevelId.
334 %************************************************************************
336 \subsection{Main interface + stubs for the non-GHCI case
338 %************************************************************************
341 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
342 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
343 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
344 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
345 -- None of these functions add constraints to the LIE
347 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
349 runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
350 runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
351 runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
354 tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
355 tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
356 tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
357 kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
359 lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
361 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
362 runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
363 runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
367 %************************************************************************
369 \subsection{Quoting an expression}
371 %************************************************************************
375 -- See Note [How brackets and nested splices are handled]
376 tcBracket brack res_ty
377 = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
379 do { -- Check for nested brackets
380 cur_stage <- getStage
381 ; checkTc (not (isBrackStage cur_stage)) illegalBracket
383 -- Brackets are desugared to code that mentions the TH package
386 -- Typecheck expr to make sure it is valid,
387 -- but throw away the results. We'll type check
388 -- it again when we actually use it.
389 ; pending_splices <- newMutVar []
390 ; lie_var <- getLIEVar
392 ; (meta_ty, lie) <- setStage (Brack cur_stage pending_splices lie_var)
393 (getLIE (tc_bracket cur_stage brack))
394 ; tcSimplifyBracket lie
396 -- Make the expected type have the right shape
397 ; _ <- boxyUnify meta_ty res_ty
399 -- Return the original expression, not the type-decorated one
400 ; pendings <- readMutVar pending_splices
401 ; return (noLoc (HsBracketOut brack pendings)) }
403 tc_bracket :: ThStage -> HsBracket Name -> TcM TcType
404 tc_bracket outer_stage (VarBr name) -- Note [Quoting names]
405 = do { thing <- tcLookup name
407 AGlobal _ -> return ()
408 ATcId { tct_level = bind_lvl, tct_id = id }
409 | thTopLevelId id -- C.f TcExpr.checkCrossStageLifting
412 -> do { checkTc (thLevel outer_stage + 1 == bind_lvl)
413 (quotedNameStageErr name) }
414 _ -> pprPanic "th_bracket" (ppr name)
416 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
419 tc_bracket _ (ExpBr expr)
420 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
421 ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
422 ; tcMetaTy expQTyConName }
423 -- Result type is Expr (= Q Exp)
425 tc_bracket _ (TypBr typ)
426 = do { _ <- tcHsSigTypeNC ThBrackCtxt typ
427 ; tcMetaTy typeQTyConName }
428 -- Result type is Type (= Q Typ)
430 tc_bracket _ (DecBr decls)
431 = do { _ <- tcTopSrcDecls emptyModDetails decls
432 -- Typecheck the declarations, dicarding the result
433 -- We'll get all that stuff later, when we splice it in
435 ; decl_ty <- tcMetaTy decTyConName
436 ; q_ty <- tcMetaTy qTyConName
437 ; return (mkAppTy q_ty (mkListTy decl_ty))
438 -- Result type is Q [Dec]
441 tc_bracket _ (PatBr _)
442 = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
444 quotedNameStageErr :: Name -> SDoc
446 = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
447 , ptext (sLit "must be used at the same stage at which is is bound")]
451 %************************************************************************
453 \subsection{Splicing an expression}
455 %************************************************************************
458 tcSpliceExpr (HsSplice name expr) res_ty
459 = setSrcSpan (getLoc expr) $ do
462 Splice -> tcTopSplice expr res_ty ;
463 Comp -> tcTopSplice expr res_ty ;
465 Brack pop_stage ps_var lie_var -> do
467 -- See Note [How brackets and nested splices are handled]
468 -- A splice inside brackets
469 -- NB: ignore res_ty, apart from zapping it to a mono-type
470 -- e.g. [| reverse $(h 4) |]
471 -- Here (h 4) :: Q Exp
472 -- but $(h 4) :: forall a.a i.e. anything!
475 ; meta_exp_ty <- tcMetaTy expQTyConName
476 ; expr' <- setStage pop_stage $
478 tcMonoExpr expr meta_exp_ty
480 -- Write the pending splice into the bucket
481 ; ps <- readMutVar ps_var
482 ; writeMutVar ps_var ((name,expr') : ps)
484 ; return (panic "tcSpliceExpr") -- The returned expression is ignored
487 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (HsExpr Id)
488 -- Note [How top-level splices are handled]
489 tcTopSplice expr res_ty
490 = do { meta_exp_ty <- tcMetaTy expQTyConName
492 -- Typecheck the expression
493 ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
495 -- Run the expression
496 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
497 ; expr2 <- runMetaE convertToHsExpr zonked_q_expr
499 ; traceTc (text "Got result" <+> ppr expr2)
501 ; showSplice "expression" expr (ppr expr2)
503 -- Rename it, but bale out if there are errors
504 -- otherwise the type checker just gives more spurious errors
505 ; (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
507 ; exp4 <- tcMonoExpr exp3 res_ty
508 ; return (unLoc exp4) }
511 tcTopSpliceExpr :: TcM (LHsExpr Id) -> TcM (LHsExpr Id)
512 -- Note [How top-level splices are handled]
513 -- Type check an expression that is the body of a top-level splice
514 -- (the caller will compile and run it)
515 -- Note that set the level to Splice, regardless of the original level,
516 -- before typechecking the expression. For example:
517 -- f x = $( ...$(g 3) ... )
518 -- The recursive call to tcMonoExpr will simply expand the
519 -- inner escape before dealing with the outer one
521 tcTopSpliceExpr tc_action
522 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
523 -- if the type checker fails!
525 do { -- Typecheck the expression
526 (expr', lie) <- getLIE tc_action
528 -- Solve the constraints
529 ; const_binds <- tcSimplifyTop lie
531 -- Zonk it and tie the knot of dictionary bindings
532 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
536 %************************************************************************
540 %************************************************************************
542 Very like splicing an expression, but we don't yet share code.
545 kcSpliceType (HsSplice name hs_expr)
546 = setSrcSpan (getLoc hs_expr) $ do
549 Splice -> kcTopSpliceType hs_expr ;
550 Comp -> kcTopSpliceType hs_expr ;
552 Brack pop_level ps_var lie_var -> do
553 -- See Note [How brackets and nested splices are handled]
554 -- A splice inside brackets
555 { meta_ty <- tcMetaTy typeQTyConName
556 ; expr' <- setStage pop_level $
558 tcMonoExpr hs_expr meta_ty
560 -- Write the pending splice into the bucket
561 ; ps <- readMutVar ps_var
562 ; writeMutVar ps_var ((name,expr') : ps)
564 -- e.g. [| f (g :: Int -> $(h 4)) |]
565 -- Here (h 4) :: Q Type
566 -- but $(h 4) :: a i.e. any type, of any kind
568 -- We return a HsSpliceTyOut, which serves to convey the kind to
569 -- the ensuing TcHsType.dsHsType, which makes up a non-committal
570 -- type variable of a suitable kind
572 ; return (HsSpliceTyOut kind, kind)
575 kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
576 -- Note [How top-level splices are handled]
578 = do { meta_ty <- tcMetaTy typeQTyConName
580 -- Typecheck the expression
581 ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_ty)
583 -- Run the expression
584 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
585 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
587 ; traceTc (text "Got result" <+> ppr hs_ty2)
589 ; showSplice "type" expr (ppr hs_ty2)
591 -- Rename it, but bale out if there are errors
592 -- otherwise the type checker just gives more spurious errors
593 ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
594 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
596 ; (ty4, kind) <- kcLHsType hs_ty3
597 ; return (unLoc ty4, kind) }
600 %************************************************************************
602 \subsection{Splicing an expression}
604 %************************************************************************
607 -- Note [How top-level splices are handled]
608 -- Always at top level
609 -- Type sig at top of file:
610 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
612 = do { meta_dec_ty <- tcMetaTy decTyConName
613 ; meta_q_ty <- tcMetaTy qTyConName
614 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
615 ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr list_q)
617 -- Run the expression
618 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
619 ; decls <- runMetaD convertToHsDecls zonked_q_expr
621 ; traceTc (text "Got result" <+> vcat (map ppr decls))
622 ; showSplice "declarations"
624 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
629 %************************************************************************
633 %************************************************************************
636 runAnnotation target expr = do
637 -- Find the classes we want instances for in order to call toAnnotationWrapper
639 data_class <- tcLookupClass dataClassName
640 to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
642 -- Check the instances we require live in another module (we want to execute it..)
643 -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
644 -- also resolves the LIE constraints to detect e.g. instance ambiguity
645 zonked_wrapped_expr' <- tcTopSpliceExpr $
646 do { (expr', expr_ty) <- tcInferRhoNC expr
647 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
648 -- By instantiating the call >here< it gets registered in the
649 -- LIE consulted by tcTopSpliceExpr
650 -- and hence ensures the appropriate dictionary is bound by const_binds
651 ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
652 ; let specialised_to_annotation_wrapper_expr
653 = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
654 ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
656 -- Run the appropriately wrapped expression to get the value of
657 -- the annotation and its dictionaries. The return value is of
658 -- type AnnotationWrapper by construction, so this conversion is
660 flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper ->
661 case annotation_wrapper of
662 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
663 -- Got the value and dictionaries: build the serialized value and
664 -- call it a day. We ensure that we seq the entire serialized value
665 -- in order that any errors in the user-written code for the
666 -- annotation are exposed at this point. This is also why we are
667 -- doing all this stuff inside the context of runMeta: it has the
668 -- facilities to deal with user error in a meta-level expression
669 seqSerialized serialized `seq` Annotation {
671 ann_value = serialized
676 %************************************************************************
680 %************************************************************************
682 Note [Quasi-quote overview]
683 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
684 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
685 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
690 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
691 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
692 defined in another module, because we are going to run it here. It's
693 a bit like a TH splice:
696 However, you can do this in patterns as well as terms. Becuase of this,
697 the splice is run by the *renamer* rather than the type checker.
700 runQuasiQuote :: Outputable hs_syn
701 => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
702 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
703 -> String -- Documentation string only
704 -> Name -- Name of th_syn type
705 -> (SrcSpan -> th_syn -> Either Message hs_syn)
707 runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
708 = do { -- Check that the quoter is not locally defined, otherwise the TH
709 -- machinery will not be able to run the quasiquote.
710 ; this_mod <- getModule
711 ; let is_local = case nameModule_maybe quoter of
712 Just mod | mod == this_mod -> True
715 ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
716 ; checkTc (not is_local) (quoteStageError quoter)
718 -- Build the expression
719 ; let quoterExpr = L q_span $! HsVar $! quoter
720 ; let quoteExpr = L q_span $! HsLit $! HsString quote
721 ; let expr = L q_span $
723 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
724 ; meta_exp_ty <- tcMetaTy meta_ty
726 -- Typecheck the expression
727 ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
729 -- Run the expression
730 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
731 ; result <- runMetaQ convert zonked_q_expr
732 ; traceTc (text "Got result" <+> ppr result)
733 ; showSplice desc quoteExpr (ppr result)
737 runQuasiQuoteExpr quasiquote
738 = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
740 runQuasiQuotePat quasiquote
741 = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
743 quoteStageError :: Name -> SDoc
744 quoteStageError quoter
745 = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
746 nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
750 %************************************************************************
752 \subsection{Running an expression}
754 %************************************************************************
757 runMetaAW :: (AnnotationWrapper -> output)
758 -> LHsExpr Id -- Of type AnnotationWrapper
760 runMetaAW k = runMeta False (\_ -> return . Right . k)
761 -- We turn off showing the code in meta-level exceptions because doing so exposes
762 -- the toAnnotationWrapper function that we slap around the users code
764 runQThen :: (SrcSpan -> input -> Either Message output)
767 -> TcM (Either Message output)
768 runQThen f expr_span what = TH.runQ what >>= (return . f expr_span)
770 runMetaQ :: (SrcSpan -> input -> Either Message output)
773 runMetaQ = runMeta True . runQThen
775 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
776 -> LHsExpr Id -- Of type (Q Exp)
777 -> TcM (LHsExpr RdrName)
780 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
781 -> LHsExpr Id -- Of type (Q Pat)
785 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
786 -> LHsExpr Id -- Of type (Q Type)
787 -> TcM (LHsType RdrName)
790 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
791 -> LHsExpr Id -- Of type Q [Dec]
792 -> TcM [LHsDecl RdrName]
795 runMeta :: Bool -- Whether code should be printed in the exception message
796 -> (SrcSpan -> input -> TcM (Either Message output))
797 -> LHsExpr Id -- Of type X
798 -> TcM output -- Of type t
799 runMeta show_code run_and_convert expr
801 ds_expr <- initDsTc (dsLExpr expr)
802 -- Compile and link it; might fail if linking fails
803 ; hsc_env <- getTopEnv
804 ; src_span <- getSrcSpanM
805 ; either_hval <- tryM $ liftIO $
806 HscMain.compileExpr hsc_env src_span ds_expr
807 ; case either_hval of {
808 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
811 { -- Coerce it to Q t, and run it
813 -- Running might fail if it throws an exception of any kind (hence tryAllM)
814 -- including, say, a pattern-match exception in the code we are running
816 -- We also do the TH -> HS syntax conversion inside the same
817 -- exception-cacthing thing so that if there are any lurking
818 -- exceptions in the data structure returned by hval, we'll
819 -- encounter them inside the try
821 -- See Note [Exceptions in TH]
822 let expr_span = getLoc expr
823 ; either_tval <- tryAllM $
824 setSrcSpan expr_span $ -- Set the span so that qLocation can
825 -- see where this splice is
826 do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
828 Left err -> failWithTc err
829 Right result -> return $! result }
831 ; case either_tval of
834 case fromException se of
836 failM -- Error already in Tc monad
837 _ -> failWithTc (mk_msg "run" se) -- Exception
840 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
841 nest 2 (text (Panic.showException exn)),
842 if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
845 Note [Exceptions in TH]
846 ~~~~~~~~~~~~~~~~~~~~~~~
847 Supppose we have something like this
851 f n | n>3 = fail "Too many declarations"
854 The 'fail' is a user-generated failure, and should be displayed as a
855 perfectly ordinary compiler error message, not a panic or anything
856 like that. Here's how it's processed:
858 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
859 effectively transforms (fail s) to
860 qReport True s >> fail
861 where 'qReport' comes from the Quasi class and fail from its monad
864 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
865 (qReport True s) by using addErr to add an error message to the bag of errors.
866 The 'fail' in TcM raises an IOEnvFailure exception
868 * So, when running a splice, we catch all exceptions; then for
869 - an IOEnvFailure exception, we assume the error is already
870 in the error-bag (above)
871 - other errors, we add an error to the bag
875 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
878 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
879 qNewName s = do { u <- newUnique
881 ; return (TH.mkNameU s i) }
883 qReport True msg = addErr (text msg)
884 qReport False msg = addReport (text msg)
886 qLocation = do { m <- getModule
888 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
889 , TH.loc_module = moduleNameString (moduleName m)
890 , TH.loc_package = packageIdString (modulePackageId m)
891 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
892 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
896 -- For qRecover, discard error messages if
897 -- the recovery action is chosen. Otherwise
898 -- we'll only fail higher up. c.f. tryTcLIE_
899 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
901 Just val -> do { addMessages msgs -- There might be warnings
903 Nothing -> recover -- Discard all msgs
906 qRunIO io = liftIO io
910 %************************************************************************
912 \subsection{Errors and contexts}
914 %************************************************************************
917 showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
918 -- Note that 'before' is *renamed* but not *typechecked*
919 -- Reason (a) less typechecking crap
920 -- (b) data constructors after type checking have been
921 -- changed to their *wrappers*, and that makes them
922 -- print always fully qualified
923 showSplice what before after
924 = do { loc <- getSrcSpanM
925 ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
926 nest 2 (sep [nest 2 (ppr before),
930 illegalBracket :: SDoc
931 illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
936 %************************************************************************
940 %************************************************************************
944 reify :: TH.Name -> TcM TH.Info
946 = do { name <- lookupThName th_name
947 ; thing <- tcLookupTh name
948 -- ToDo: this tcLookup could fail, which would give a
949 -- rather unhelpful error message
950 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
954 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
955 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
956 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
957 ppr_ns _ = panic "reify/ppr_ns"
959 lookupThName :: TH.Name -> TcM Name
960 lookupThName th_name = do
961 mb_name <- lookupThName_maybe th_name
963 Nothing -> failWithTc (notInScope th_name)
964 Just name -> return name
966 lookupThName_maybe th_name
967 = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
968 -- Pick the first that works
969 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
970 ; return (listToMaybe names) }
973 = do { -- Repeat much of lookupOccRn, becase we want
974 -- to report errors in a TH-relevant way
975 ; rdr_env <- getLocalRdrEnv
976 ; case lookupLocalRdrEnv rdr_env rdr_name of
977 Just name -> return (Just name)
978 Nothing -> lookupGlobalOccRn_maybe rdr_name }
980 tcLookupTh :: Name -> TcM TcTyThing
981 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
982 -- it gives a reify-related error message on failure, whereas in the normal
983 -- tcLookup, failure is a bug.
985 = do { (gbl_env, lcl_env) <- getEnvs
986 ; case lookupNameEnv (tcl_env lcl_env) name of {
987 Just thing -> return thing;
989 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
990 then -- It's defined in this module
991 case lookupNameEnv (tcg_type_env gbl_env) name of
992 Just thing -> return (AGlobal thing)
993 Nothing -> failWithTc (notInEnv name)
995 else do -- It's imported
996 { (eps,hpt) <- getEpsAndHpt
998 ; case lookupType dflags hpt (eps_PTE eps) name of
999 Just thing -> return (AGlobal thing)
1000 Nothing -> do { thing <- tcImportDecl name
1001 ; return (AGlobal thing) }
1002 -- Imported names should always be findable;
1003 -- if not, we fail hard in tcImportDecl
1006 notInScope :: TH.Name -> SDoc
1007 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
1008 ptext (sLit "is not in scope at a reify")
1009 -- Ugh! Rather an indirect way to display the name
1011 notInEnv :: Name -> SDoc
1012 notInEnv name = quotes (ppr name) <+>
1013 ptext (sLit "is not in the type environment at a reify")
1015 ------------------------------
1016 reifyThing :: TcTyThing -> TcM TH.Info
1017 -- The only reason this is monadic is for error reporting,
1018 -- which in turn is mainly for the case when TH can't express
1019 -- some random GHC extension
1021 reifyThing (AGlobal (AnId id))
1022 = do { ty <- reifyType (idType id)
1023 ; fix <- reifyFixity (idName id)
1024 ; let v = reifyName id
1025 ; case idDetails id of
1026 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
1027 _ -> return (TH.VarI v ty Nothing fix)
1030 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
1031 reifyThing (AGlobal (AClass cls)) = reifyClass cls
1032 reifyThing (AGlobal (ADataCon dc))
1033 = do { let name = dataConName dc
1034 ; ty <- reifyType (idType (dataConWrapId dc))
1035 ; fix <- reifyFixity name
1036 ; return (TH.DataConI (reifyName name) ty
1037 (reifyName (dataConOrigTyCon dc)) fix)
1040 reifyThing (ATcId {tct_id = id, tct_type = ty})
1041 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
1042 -- though it may be incomplete
1043 ; ty2 <- reifyType ty1
1044 ; fix <- reifyFixity (idName id)
1045 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
1047 reifyThing (ATyVar tv ty)
1048 = do { ty1 <- zonkTcType ty
1049 ; ty2 <- reifyType ty1
1050 ; return (TH.TyVarI (reifyName tv) ty2) }
1052 reifyThing (AThing {}) = panic "reifyThing AThing"
1054 ------------------------------
1055 reifyTyCon :: TyCon -> TcM TH.Info
1058 = return (TH.PrimTyConI (reifyName tc) 2 False)
1060 = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
1062 = let flavour = reifyFamFlavour tc
1063 tvs = tyConTyVars tc
1066 | isLiftedTypeKind kind = Nothing
1067 | otherwise = Just $ reifyKind kind
1070 TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
1072 = do { let (tvs, rhs) = synTyConDefn tc
1073 ; rhs' <- reifyType rhs
1074 ; return (TH.TyConI $
1075 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
1079 = do { cxt <- reifyCxt (tyConStupidTheta tc)
1080 ; let tvs = tyConTyVars tc
1081 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
1082 ; let name = reifyName tc
1083 r_tvs = reifyTyVars tvs
1084 deriv = [] -- Don't know about deriving
1085 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
1086 | otherwise = TH.DataD cxt name r_tvs cons deriv
1087 ; return (TH.TyConI decl) }
1089 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
1091 | isVanillaDataCon dc
1092 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
1093 ; let stricts = map reifyStrict (dataConStrictMarks dc)
1094 fields = dataConFieldLabels dc
1098 ; ASSERT( length arg_tys == length stricts )
1099 if not (null fields) then
1100 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
1102 if dataConIsInfix dc then
1103 ASSERT( length arg_tys == 2 )
1104 return (TH.InfixC (s1,a1) name (s2,a2))
1106 return (TH.NormalC name (stricts `zip` arg_tys)) }
1108 = failWithTc (ptext (sLit "Can't reify a GADT data constructor:")
1109 <+> quotes (ppr dc))
1111 ------------------------------
1112 reifyClass :: Class -> TcM TH.Info
1114 = do { cxt <- reifyCxt theta
1115 ; ops <- mapM reify_op op_stuff
1116 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
1118 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
1119 fds' = map reifyFunDep fds
1120 reify_op (op, _) = do { ty <- reifyType (idType op)
1121 ; return (TH.SigD (reifyName op) ty) }
1123 ------------------------------
1124 reifyType :: TypeRep.Type -> TcM TH.Type
1125 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1126 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
1127 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1128 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1129 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
1130 ; tau' <- reifyType tau
1131 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
1133 (tvs, cxt, tau) = tcSplitSigmaTy ty
1134 reifyType (PredTy {}) = panic "reifyType PredTy"
1136 reifyTypes :: [Type] -> TcM [TH.Type]
1137 reifyTypes = mapM reifyType
1139 reifyKind :: Kind -> TH.Kind
1141 = let (kis, ki') = splitKindFunTys ki
1142 kis_rep = map reifyKind kis
1143 ki'_rep = reifyNonArrowKind ki'
1145 foldl TH.ArrowK ki'_rep kis_rep
1147 reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
1148 | otherwise = pprPanic "Exotic form of kind"
1151 reifyCxt :: [PredType] -> TcM [TH.Pred]
1152 reifyCxt = mapM reifyPred
1154 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1155 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1157 reifyFamFlavour :: TyCon -> TH.FamFlavour
1158 reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
1159 | isOpenTyCon tc = TH.DataFam
1161 = panic "TcSplice.reifyFamFlavour: not a type family"
1163 reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
1164 reifyTyVars = map reifyTyVar
1166 reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV name
1167 | otherwise = TH.KindedTV name (reifyKind kind)
1172 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
1173 reify_tc_app tc tys = do { tys' <- reifyTypes tys
1174 ; return (foldl TH.AppT (TH.ConT tc) tys') }
1176 reifyPred :: TypeRep.PredType -> TcM TH.Pred
1177 reifyPred (ClassP cls tys)
1178 = do { tys' <- reifyTypes tys
1179 ; return $ TH.ClassP (reifyName cls) tys'
1181 reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
1182 reifyPred (EqPred ty1 ty2)
1183 = do { ty1' <- reifyType ty1
1184 ; ty2' <- reifyType ty2
1185 ; return $ TH.EqualP ty1' ty2'
1189 ------------------------------
1190 reifyName :: NamedThing n => n -> TH.Name
1192 | isExternalName name = mk_varg pkg_str mod_str occ_str
1193 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1194 -- Many of the things we reify have local bindings, and
1195 -- NameL's aren't supposed to appear in binding positions, so
1196 -- we use NameU. When/if we start to reify nested things, that
1197 -- have free variables, we may need to generate NameL's for them.
1199 name = getName thing
1200 mod = ASSERT( isExternalName name ) nameModule name
1201 pkg_str = packageIdString (modulePackageId mod)
1202 mod_str = moduleNameString (moduleName mod)
1203 occ_str = occNameString occ
1204 occ = nameOccName name
1205 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1206 | OccName.isVarOcc occ = TH.mkNameG_v
1207 | OccName.isTcOcc occ = TH.mkNameG_tc
1208 | otherwise = pprPanic "reifyName" (ppr name)
1210 ------------------------------
1211 reifyFixity :: Name -> TcM TH.Fixity
1213 = do { fix <- lookupFixityRn name
1214 ; return (conv_fix fix) }
1216 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1217 conv_dir BasicTypes.InfixR = TH.InfixR
1218 conv_dir BasicTypes.InfixL = TH.InfixL
1219 conv_dir BasicTypes.InfixN = TH.InfixN
1221 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
1222 reifyStrict MarkedStrict = TH.IsStrict
1223 reifyStrict MarkedUnboxed = TH.IsStrict
1224 reifyStrict NotMarkedStrict = TH.NotStrict
1226 ------------------------------
1227 noTH :: LitString -> SDoc -> TcM a
1228 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1229 ptext (sLit "in Template Haskell:"),