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,
19 runQuasiQuoteExpr, runQuasiQuotePat,
20 runQuasiQuoteDecl, runQuasiQuoteType,
23 #include "HsVersions.h"
27 -- These imports are the reason that TcSplice
28 -- is very high up the module hierarchy
66 import DsMonad hiding (Splice)
77 import Control.Monad ( when )
79 import qualified Language.Haskell.TH as TH
80 -- THSyntax gives access to internal functions and data types
81 import qualified Language.Haskell.TH.Syntax as TH
84 -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
85 import GHC.Desugar ( AnnotationWrapper(..) )
88 import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
89 import System.IO.Error
92 Note [How top-level splices are handled]
93 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
94 Top-level splices (those not inside a [| .. |] quotation bracket) are handled
95 very straightforwardly:
97 1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
99 2. runMetaT: desugar, compile, run it, and convert result back to
100 HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,
103 3. treat the result as if that's what you saw in the first place
104 e.g for HsType, rename and kind-check
105 for HsExpr, rename and type-check
107 (The last step is different for decls, becuase they can *only* be
108 top-level: we return the result of step 2.)
110 Note [How brackets and nested splices are handled]
111 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
112 Nested splices (those inside a [| .. |] quotation bracket), are treated
115 * After typechecking, the bracket [| |] carries
117 a) A mutable list of PendingSplice
118 type PendingSplice = (Name, LHsExpr Id)
120 b) The quoted expression e, *renamed*: (HsExpr Name)
121 The expression e has been typechecked, but the result of
122 that typechecking is discarded.
124 * The brakcet is desugared by DsMeta.dsBracket. It
126 a) Extends the ds_meta environment with the PendingSplices
127 attached to the bracket
129 b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
130 run, will produce a suitable TH expression/type/decl. This
131 is why we leave the *renamed* expression attached to the bracket:
132 the quoted expression should not be decorated with all the goop
133 added by the type checker
135 * Each splice carries a unique Name, called a "splice point", thus
136 ${n}(e). The name is initialised to an (Unqual "splice") when the
137 splice is created; the renamer gives it a unique.
139 * When the type checker type-checks a nested splice ${n}(e), it
141 - adds the typechecked expression (of type (HsExpr Id))
142 as a pending splice to the enclosing bracket
143 - returns something non-committal
144 Eg for [| f ${n}(g x) |], the typechecker
145 - attaches the typechecked term (g x) to the pending splices for n
147 - returns a non-committal type \alpha.
148 Remember that the bracket discards the typechecked term altogether
150 * When DsMeta (used to desugar the body of the bracket) comes across
151 a splice, it looks up the splice's Name, n, in the ds_meta envt,
152 to find an (HsExpr Id) that should be substituted for the splice;
153 it just desugars it to get a CoreExpr (DsMeta.repSplice).
156 Source: f = [| Just $(g 3) |]
157 The [| |] part is a HsBracket
159 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
160 The [| |] part is a HsBracketOut, containing *renamed*
161 (not typechecked) expression
162 The "s7" is the "splice point"; the (g Int 3) part
163 is a typechecked expression
165 Desugared: f = do { s7 <- g Int 3
166 ; return (ConE "Data.Maybe.Just" s7) }
169 Note [Template Haskell state diagram]
170 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
171 Here are the ThStages, s, their corresponding level numbers
172 (the result of (thLevel s)), and their state transitions.
174 ----------- $ ------------ $
175 | Comp | ---------> | Splice | -----|
177 ----------- ------------
179 $ | | [||] $ | | [||]
181 -------------- ----------------
182 | Brack Comp | | Brack Splice |
184 -------------- ----------------
186 * Normal top-level declarations start in state Comp
188 Annotations start in state Splice, since they are
189 treated very like a splice (only without a '$')
191 * Code compiled in state Splice (and only such code)
192 will be *run at compile time*, with the result replacing
195 * The original paper used level -1 instead of 0, etc.
197 * The original paper did not allow a splice within a
198 splice, but there is no reason not to. This is the
199 $ transition in the top right.
201 Note [Template Haskell levels]
202 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
203 * Imported things are impLevel (= 0)
205 * In GHCi, variables bound by a previous command are treated
206 as impLevel, because we have bytecode for them.
208 * Variables are bound at the "current level"
210 * The current level starts off at outerLevel (= 1)
212 * The level is decremented by splicing $(..)
213 incremented by brackets [| |]
214 incremented by name-quoting 'f
216 When a variable is used, we compare
217 bind: binding level, and
218 use: current level at usage site
221 bind > use Always error (bound later than used)
224 bind = use Always OK (bound same stage as used)
225 [| \x -> $(f [| x |]) |]
227 bind < use Inside brackets, it depends
231 For (bind < use) inside brackets, there are three cases:
232 - Imported things OK f = [| map |]
233 - Top-level things OK g = [| f |]
234 - Non-top-level Only if there is a liftable instance
235 h = \(x:Int) -> [| x |]
237 See Note [What is a top-level Id?]
241 A quoted name 'n is a bit like a quoted expression [| n |], except that we
242 have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
243 the use-level to account for the brackets, the cases are:
252 See Note [What is a top-level Id?] in TcEnv. Examples:
254 f 'map -- OK; also for top-level defns of this module
256 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
257 -- cross-stage lifting
259 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
261 [| \x. $(f 'x) |] -- OK
264 Note [What is a top-level Id?]
265 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
266 In the level-control criteria above, we need to know what a "top level Id" is.
267 There are three kinds:
268 * Imported from another module (GlobalId, ExternalName)
269 * Bound at the top level of this module (ExternalName)
270 * In GHCi, bound by a previous stmt (GlobalId)
271 It's strange that there is no one criterion tht picks out all three, but that's
272 how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids
273 bound in an earlier Stmt, but what module would you choose? See
274 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
276 The predicate we use is TcEnv.thTopLevelId.
279 %************************************************************************
281 \subsection{Main interface + stubs for the non-GHCI case
283 %************************************************************************
286 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
287 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
288 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
289 kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind)
290 -- None of these functions add constraints to the LIE
292 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
294 runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
295 runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName)
296 runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)
297 runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
299 runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
302 tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
303 tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
304 tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
305 kcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
307 lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
309 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
310 runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
311 runQuasiQuoteType q = pprPanic "Cant do runQuasiQuoteType without GHCi" (ppr q)
312 runQuasiQuoteDecl q = pprPanic "Cant do runQuasiQuoteDecl without GHCi" (ppr q)
313 runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
317 %************************************************************************
319 \subsection{Quoting an expression}
321 %************************************************************************
325 -- See Note [How brackets and nested splices are handled]
326 tcBracket brack res_ty
327 = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
329 do { -- Check for nested brackets
330 cur_stage <- getStage
331 ; checkTc (not (isBrackStage cur_stage)) illegalBracket
333 -- Brackets are desugared to code that mentions the TH package
336 -- Typecheck expr to make sure it is valid,
337 -- but throw away the results. We'll type check
338 -- it again when we actually use it.
339 ; pending_splices <- newMutVar []
340 ; lie_var <- getLIEVar
341 ; let brack_stage = Brack cur_stage pending_splices lie_var
343 ; (meta_ty, lie) <- setStage brack_stage $
345 tc_bracket cur_stage brack
347 ; tcSimplifyBracket lie
349 -- Make the expected type have the right shape
350 ; _ <- boxyUnify meta_ty res_ty
352 -- Return the original expression, not the type-decorated one
353 ; pendings <- readMutVar pending_splices
354 ; return (noLoc (HsBracketOut brack pendings)) }
356 tc_bracket :: ThStage -> HsBracket Name -> TcM TcType
357 tc_bracket outer_stage (VarBr name) -- Note [Quoting names]
358 = do { thing <- tcLookup name
360 AGlobal _ -> return ()
361 ATcId { tct_level = bind_lvl, tct_id = id }
362 | thTopLevelId id -- C.f TcExpr.checkCrossStageLifting
365 -> do { checkTc (thLevel outer_stage + 1 == bind_lvl)
366 (quotedNameStageErr name) }
367 _ -> pprPanic "th_bracket" (ppr name)
369 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
372 tc_bracket _ (ExpBr expr)
373 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
374 ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
375 ; tcMetaTy expQTyConName }
376 -- Result type is ExpQ (= Q Exp)
378 tc_bracket _ (TypBr typ)
379 = do { _ <- tcHsSigTypeNC ThBrackCtxt typ
380 ; tcMetaTy typeQTyConName }
381 -- Result type is Type (= Q Typ)
383 tc_bracket _ (DecBrG decls)
384 = do { _ <- tcTopSrcDecls emptyModDetails decls
385 -- Typecheck the declarations, dicarding the result
386 -- We'll get all that stuff later, when we splice it in
388 -- Top-level declarations in the bracket get unqualified names
389 -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames
391 ; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
393 tc_bracket _ (PatBr pat)
394 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
395 ; _ <- tcPat ThPatQuote pat any_ty unitTy $ \_ ->
397 ; tcMetaTy patQTyConName }
398 -- Result type is PatQ (= Q Pat)
400 tc_bracket _ (DecBrL _)
401 = panic "tc_bracket: Unexpected DecBrL"
403 quotedNameStageErr :: Name -> SDoc
405 = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
406 , ptext (sLit "must be used at the same stage at which is is bound")]
410 %************************************************************************
412 \subsection{Splicing an expression}
414 %************************************************************************
417 tcSpliceExpr (HsSplice name expr) res_ty
418 = setSrcSpan (getLoc expr) $ do
421 Splice -> tcTopSplice expr res_ty ;
422 Comp -> tcTopSplice expr res_ty ;
424 Brack pop_stage ps_var lie_var -> do
426 -- See Note [How brackets and nested splices are handled]
427 -- A splice inside brackets
428 -- NB: ignore res_ty, apart from zapping it to a mono-type
429 -- e.g. [| reverse $(h 4) |]
430 -- Here (h 4) :: Q Exp
431 -- but $(h 4) :: forall a.a i.e. anything!
434 ; meta_exp_ty <- tcMetaTy expQTyConName
435 ; expr' <- setStage pop_stage $
437 tcMonoExpr expr meta_exp_ty
439 -- Write the pending splice into the bucket
440 ; ps <- readMutVar ps_var
441 ; writeMutVar ps_var ((name,expr') : ps)
443 ; return (panic "tcSpliceExpr") -- The returned expression is ignored
446 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (HsExpr Id)
447 -- Note [How top-level splices are handled]
448 tcTopSplice expr res_ty
449 = do { meta_exp_ty <- tcMetaTy expQTyConName
451 -- Typecheck the expression
452 ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
454 -- Run the expression
455 ; expr2 <- runMetaE zonked_q_expr
456 ; showSplice "expression" expr (ppr expr2)
458 -- Rename it, but bale out if there are errors
459 -- otherwise the type checker just gives more spurious errors
460 ; addErrCtxt (spliceResultDoc expr) $ do
461 { (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
463 ; exp4 <- tcMonoExpr exp3 res_ty
464 ; return (unLoc exp4) } }
466 spliceResultDoc :: LHsExpr Name -> SDoc
468 = sep [ ptext (sLit "In the result of the splice:")
469 , nest 2 (char '$' <> pprParendExpr expr)
470 , ptext (sLit "To see what the splice expanded to, use -ddump-splices")]
473 tcTopSpliceExpr :: TcM (LHsExpr Id) -> TcM (LHsExpr Id)
474 -- Note [How top-level splices are handled]
475 -- Type check an expression that is the body of a top-level splice
476 -- (the caller will compile and run it)
477 -- Note that set the level to Splice, regardless of the original level,
478 -- before typechecking the expression. For example:
479 -- f x = $( ...$(g 3) ... )
480 -- The recursive call to tcMonoExpr will simply expand the
481 -- inner escape before dealing with the outer one
483 tcTopSpliceExpr tc_action
484 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
485 -- if the type checker fails!
487 do { -- Typecheck the expression
488 (expr', lie) <- getLIE tc_action
490 -- Solve the constraints
491 ; const_binds <- tcSimplifyTop lie
493 -- Zonk it and tie the knot of dictionary bindings
494 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
498 %************************************************************************
502 %************************************************************************
504 Very like splicing an expression, but we don't yet share code.
507 kcSpliceType splice@(HsSplice name hs_expr) fvs
508 = setSrcSpan (getLoc hs_expr) $ do
511 Splice -> kcTopSpliceType hs_expr ;
512 Comp -> kcTopSpliceType hs_expr ;
514 Brack pop_level ps_var lie_var -> do
515 -- See Note [How brackets and nested splices are handled]
516 -- A splice inside brackets
517 { meta_ty <- tcMetaTy typeQTyConName
518 ; expr' <- setStage pop_level $
520 tcMonoExpr hs_expr meta_ty
522 -- Write the pending splice into the bucket
523 ; ps <- readMutVar ps_var
524 ; writeMutVar ps_var ((name,expr') : ps)
526 -- e.g. [| f (g :: Int -> $(h 4)) |]
527 -- Here (h 4) :: Q Type
528 -- but $(h 4) :: a i.e. any type, of any kind
531 ; return (HsSpliceTy splice fvs kind, kind)
534 kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
535 -- Note [How top-level splices are handled]
537 = do { meta_ty <- tcMetaTy typeQTyConName
539 -- Typecheck the expression
540 ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_ty)
542 -- Run the expression
543 ; hs_ty2 <- runMetaT zonked_q_expr
544 ; showSplice "type" expr (ppr hs_ty2)
546 -- Rename it, but bale out if there are errors
547 -- otherwise the type checker just gives more spurious errors
548 ; addErrCtxt (spliceResultDoc expr) $ do
549 { let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
550 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
551 ; (ty4, kind) <- kcLHsType hs_ty3
552 ; return (unLoc ty4, kind) }}
555 %************************************************************************
557 \subsection{Splicing an expression}
559 %************************************************************************
562 -- Note [How top-level splices are handled]
563 -- Always at top level
564 -- Type sig at top of file:
565 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
567 = do { list_q <- tcMetaTy decsQTyConName -- Q [Dec]
568 ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr list_q)
570 -- Run the expression
571 ; decls <- runMetaD zonked_q_expr
572 ; showSplice "declarations" expr
573 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
579 %************************************************************************
583 %************************************************************************
586 runAnnotation target expr = do
587 -- Find the classes we want instances for in order to call toAnnotationWrapper
589 data_class <- tcLookupClass dataClassName
590 to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
592 -- Check the instances we require live in another module (we want to execute it..)
593 -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
594 -- also resolves the LIE constraints to detect e.g. instance ambiguity
595 zonked_wrapped_expr' <- tcTopSpliceExpr $
596 do { (expr', expr_ty) <- tcInferRhoNC expr
597 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
598 -- By instantiating the call >here< it gets registered in the
599 -- LIE consulted by tcTopSpliceExpr
600 -- and hence ensures the appropriate dictionary is bound by const_binds
601 ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
602 ; let specialised_to_annotation_wrapper_expr
603 = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
604 ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
606 -- Run the appropriately wrapped expression to get the value of
607 -- the annotation and its dictionaries. The return value is of
608 -- type AnnotationWrapper by construction, so this conversion is
610 flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper ->
611 case annotation_wrapper of
612 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
613 -- Got the value and dictionaries: build the serialized value and
614 -- call it a day. We ensure that we seq the entire serialized value
615 -- in order that any errors in the user-written code for the
616 -- annotation are exposed at this point. This is also why we are
617 -- doing all this stuff inside the context of runMeta: it has the
618 -- facilities to deal with user error in a meta-level expression
619 seqSerialized serialized `seq` Annotation {
621 ann_value = serialized
626 %************************************************************************
630 %************************************************************************
632 Note [Quasi-quote overview]
633 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
634 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
635 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
640 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
641 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
642 defined in another module, because we are going to run it here. It's
643 a bit like a TH splice:
646 However, you can do this in patterns as well as terms. Becuase of this,
647 the splice is run by the *renamer* rather than the type checker.
649 %************************************************************************
651 \subsubsection{Quasiquotation}
653 %************************************************************************
655 See Note [Quasi-quote overview] in TcSplice.
658 runQuasiQuote :: Outputable hs_syn
659 => HsQuasiQuote RdrName -- Contains term of type QuasiQuoter, and the String
660 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
661 -> Name -- Name of th_syn type
662 -> MetaOps th_syn hs_syn
664 runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops
665 = do { quoter' <- lookupOccRn quoter
666 -- We use lookupOcc rather than lookupGlobalOcc because in the
667 -- erroneous case of \x -> [x| ...|] we get a better error message
668 -- (stage restriction rather than out of scope).
670 ; when (isUnboundName quoter') failM
671 -- If 'quoter' is not in scope, proceed no further
672 -- The error message was generated by lookupOccRn, but it then
673 -- succeeds with an "unbound name", which makes the subsequent
674 -- attempt to run the quote fail in a confusing way
676 -- Check that the quoter is not locally defined, otherwise the TH
677 -- machinery will not be able to run the quasiquote.
678 ; this_mod <- getModule
679 ; let is_local = nameIsLocalOrFrom this_mod quoter'
680 ; checkTc (not is_local) (quoteStageError quoter')
682 ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
684 -- Build the expression
685 ; let quoterExpr = L q_span $! HsVar $! quoter'
686 ; let quoteExpr = L q_span $! HsLit $! HsString quote
687 ; let expr = L q_span $
689 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
690 ; meta_exp_ty <- tcMetaTy meta_ty
692 -- Typecheck the expression
693 ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
695 -- Run the expression
696 ; result <- runMetaQ meta_ops zonked_q_expr
697 ; showSplice (mt_desc meta_ops) quoteExpr (ppr result)
701 runQuasiQuoteExpr qq = runQuasiQuote qq quoteExpName expQTyConName exprMetaOps
702 runQuasiQuotePat qq = runQuasiQuote qq quotePatName patQTyConName patMetaOps
703 runQuasiQuoteType qq = runQuasiQuote qq quoteTypeName typeQTyConName typeMetaOps
704 runQuasiQuoteDecl qq = runQuasiQuote qq quoteDecName decsQTyConName declMetaOps
706 quoteStageError :: Name -> SDoc
707 quoteStageError quoter
708 = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
709 nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
713 %************************************************************************
715 \subsection{Running an expression}
717 %************************************************************************
720 data MetaOps th_syn hs_syn
721 = MT { mt_desc :: String -- Type of beast (expression, type etc)
722 , mt_show :: th_syn -> String -- How to show the th_syn thing
723 , mt_cvt :: SrcSpan -> th_syn -> Either Message hs_syn
724 -- How to convert to hs_syn
727 exprMetaOps :: MetaOps TH.Exp (LHsExpr RdrName)
728 exprMetaOps = MT { mt_desc = "expression", mt_show = TH.pprint, mt_cvt = convertToHsExpr }
730 patMetaOps :: MetaOps TH.Pat (LPat RdrName)
731 patMetaOps = MT { mt_desc = "pattern", mt_show = TH.pprint, mt_cvt = convertToPat }
733 typeMetaOps :: MetaOps TH.Type (LHsType RdrName)
734 typeMetaOps = MT { mt_desc = "type", mt_show = TH.pprint, mt_cvt = convertToHsType }
736 declMetaOps :: MetaOps [TH.Dec] [LHsDecl RdrName]
737 declMetaOps = MT { mt_desc = "declarations", mt_show = TH.pprint, mt_cvt = convertToHsDecls }
740 runMetaAW :: Outputable output
741 => (AnnotationWrapper -> output)
742 -> LHsExpr Id -- Of type AnnotationWrapper
744 runMetaAW k = runMeta False (\_ -> return . Right . k)
745 -- We turn off showing the code in meta-level exceptions because doing so exposes
746 -- the toAnnotationWrapper function that we slap around the users code
749 runMetaQ :: Outputable hs_syn
750 => MetaOps th_syn hs_syn
753 runMetaQ (MT { mt_show = show_th, mt_cvt = cvt }) expr
754 = runMeta True run_and_cvt expr
756 run_and_cvt expr_span hval
757 = do { th_result <- TH.runQ hval
758 ; traceTc (text "Got TH result:" <+> text (show_th th_result))
759 ; return (cvt expr_span th_result) }
761 runMetaE :: LHsExpr Id -- Of type (Q Exp)
762 -> TcM (LHsExpr RdrName)
763 runMetaE = runMetaQ exprMetaOps
765 runMetaT :: LHsExpr Id -- Of type (Q Type)
766 -> TcM (LHsType RdrName)
767 runMetaT = runMetaQ typeMetaOps
769 runMetaD :: LHsExpr Id -- Of type Q [Dec]
770 -> TcM [LHsDecl RdrName]
771 runMetaD = runMetaQ declMetaOps
774 runMeta :: (Outputable hs_syn)
775 => Bool -- Whether code should be printed in the exception message
776 -> (SrcSpan -> x -> TcM (Either Message hs_syn)) -- How to run x
777 -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that
778 -> TcM hs_syn -- Of type t
779 runMeta show_code run_and_convert expr
780 = do { traceTc (text "About to run" <+> ppr expr)
783 ; ds_expr <- initDsTc (dsLExpr expr)
784 -- Compile and link it; might fail if linking fails
785 ; hsc_env <- getTopEnv
786 ; src_span <- getSrcSpanM
787 ; either_hval <- tryM $ liftIO $
788 HscMain.compileExpr hsc_env src_span ds_expr
789 ; case either_hval of {
790 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
793 { -- Coerce it to Q t, and run it
795 -- Running might fail if it throws an exception of any kind (hence tryAllM)
796 -- including, say, a pattern-match exception in the code we are running
798 -- We also do the TH -> HS syntax conversion inside the same
799 -- exception-cacthing thing so that if there are any lurking
800 -- exceptions in the data structure returned by hval, we'll
801 -- encounter them inside the try
803 -- See Note [Exceptions in TH]
804 let expr_span = getLoc expr
805 ; either_tval <- tryAllM $
806 setSrcSpan expr_span $ -- Set the span so that qLocation can
807 -- see where this splice is
808 do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
810 Left err -> failWithTc err
811 Right result -> do { traceTc (ptext (sLit "Got HsSyn result:") <+> ppr result)
812 ; return $! result } }
814 ; case either_tval of
816 Left se -> case fromException se of
817 Just IOEnvFailure -> failM -- Error already in Tc monad
818 _ -> failWithTc (mk_msg "run" se) -- Exception
821 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
822 nest 2 (text (Panic.showException exn)),
823 if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
826 Note [Exceptions in TH]
827 ~~~~~~~~~~~~~~~~~~~~~~~
828 Supppose we have something like this
832 f n | n>3 = fail "Too many declarations"
835 The 'fail' is a user-generated failure, and should be displayed as a
836 perfectly ordinary compiler error message, not a panic or anything
837 like that. Here's how it's processed:
839 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
840 effectively transforms (fail s) to
841 qReport True s >> fail
842 where 'qReport' comes from the Quasi class and fail from its monad
845 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
846 (qReport True s) by using addErr to add an error message to the bag of errors.
847 The 'fail' in TcM raises an IOEnvFailure exception
849 * So, when running a splice, we catch all exceptions; then for
850 - an IOEnvFailure exception, we assume the error is already
851 in the error-bag (above)
852 - other errors, we add an error to the bag
856 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
859 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
860 qNewName s = do { u <- newUnique
862 ; return (TH.mkNameU s i) }
864 qReport True msg = addErr (text msg)
865 qReport False msg = addReport (text msg) empty
867 qLocation = do { m <- getModule
869 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
870 , TH.loc_module = moduleNameString (moduleName m)
871 , TH.loc_package = packageIdString (modulePackageId m)
872 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
873 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
877 -- For qRecover, discard error messages if
878 -- the recovery action is chosen. Otherwise
879 -- we'll only fail higher up. c.f. tryTcLIE_
880 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
882 Just val -> do { addMessages msgs -- There might be warnings
884 Nothing -> recover -- Discard all msgs
887 qRunIO io = liftIO io
891 %************************************************************************
893 \subsection{Errors and contexts}
895 %************************************************************************
898 showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
899 -- Note that 'before' is *renamed* but not *typechecked*
900 -- Reason (a) less typechecking crap
901 -- (b) data constructors after type checking have been
902 -- changed to their *wrappers*, and that makes them
903 -- print always fully qualified
904 showSplice what before after
905 = do { loc <- getSrcSpanM
906 ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
907 nest 2 (sep [nest 2 (ppr before),
911 illegalBracket :: SDoc
912 illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
917 %************************************************************************
921 %************************************************************************
925 reify :: TH.Name -> TcM TH.Info
927 = do { name <- lookupThName th_name
928 ; thing <- tcLookupTh name
929 -- ToDo: this tcLookup could fail, which would give a
930 -- rather unhelpful error message
931 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
935 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
936 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
937 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
938 ppr_ns _ = panic "reify/ppr_ns"
940 lookupThName :: TH.Name -> TcM Name
941 lookupThName th_name = do
942 mb_name <- lookupThName_maybe th_name
944 Nothing -> failWithTc (notInScope th_name)
945 Just name -> return name
947 lookupThName_maybe th_name
948 = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
949 -- Pick the first that works
950 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
951 ; return (listToMaybe names) }
954 = do { -- Repeat much of lookupOccRn, becase we want
955 -- to report errors in a TH-relevant way
956 ; rdr_env <- getLocalRdrEnv
957 ; case lookupLocalRdrEnv rdr_env rdr_name of
958 Just name -> return (Just name)
959 Nothing -> lookupGlobalOccRn_maybe rdr_name }
961 tcLookupTh :: Name -> TcM TcTyThing
962 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
963 -- it gives a reify-related error message on failure, whereas in the normal
964 -- tcLookup, failure is a bug.
966 = do { (gbl_env, lcl_env) <- getEnvs
967 ; case lookupNameEnv (tcl_env lcl_env) name of {
968 Just thing -> return thing;
970 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
971 then -- It's defined in this module
972 case lookupNameEnv (tcg_type_env gbl_env) name of
973 Just thing -> return (AGlobal thing)
974 Nothing -> failWithTc (notInEnv name)
976 else do -- It's imported
977 { (eps,hpt) <- getEpsAndHpt
979 ; case lookupType dflags hpt (eps_PTE eps) name of
980 Just thing -> return (AGlobal thing)
981 Nothing -> do { thing <- tcImportDecl name
982 ; return (AGlobal thing) }
983 -- Imported names should always be findable;
984 -- if not, we fail hard in tcImportDecl
987 notInScope :: TH.Name -> SDoc
988 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
989 ptext (sLit "is not in scope at a reify")
990 -- Ugh! Rather an indirect way to display the name
992 notInEnv :: Name -> SDoc
993 notInEnv name = quotes (ppr name) <+>
994 ptext (sLit "is not in the type environment at a reify")
996 ------------------------------
997 reifyThing :: TcTyThing -> TcM TH.Info
998 -- The only reason this is monadic is for error reporting,
999 -- which in turn is mainly for the case when TH can't express
1000 -- some random GHC extension
1002 reifyThing (AGlobal (AnId id))
1003 = do { ty <- reifyType (idType id)
1004 ; fix <- reifyFixity (idName id)
1005 ; let v = reifyName id
1006 ; case idDetails id of
1007 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
1008 _ -> return (TH.VarI v ty Nothing fix)
1011 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
1012 reifyThing (AGlobal (AClass cls)) = reifyClass cls
1013 reifyThing (AGlobal (ADataCon dc))
1014 = do { let name = dataConName dc
1015 ; ty <- reifyType (idType (dataConWrapId dc))
1016 ; fix <- reifyFixity name
1017 ; return (TH.DataConI (reifyName name) ty
1018 (reifyName (dataConOrigTyCon dc)) fix)
1021 reifyThing (ATcId {tct_id = id, tct_type = ty})
1022 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
1023 -- though it may be incomplete
1024 ; ty2 <- reifyType ty1
1025 ; fix <- reifyFixity (idName id)
1026 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
1028 reifyThing (ATyVar tv ty)
1029 = do { ty1 <- zonkTcType ty
1030 ; ty2 <- reifyType ty1
1031 ; return (TH.TyVarI (reifyName tv) ty2) }
1033 reifyThing (AThing {}) = panic "reifyThing AThing"
1035 ------------------------------
1036 reifyTyCon :: TyCon -> TcM TH.Info
1039 = return (TH.PrimTyConI (reifyName tc) 2 False)
1041 = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
1043 = let flavour = reifyFamFlavour tc
1044 tvs = tyConTyVars tc
1047 | isLiftedTypeKind kind = Nothing
1048 | otherwise = Just $ reifyKind kind
1051 TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
1053 = do { let (tvs, rhs) = synTyConDefn tc
1054 ; rhs' <- reifyType rhs
1055 ; return (TH.TyConI $
1056 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
1060 = do { cxt <- reifyCxt (tyConStupidTheta tc)
1061 ; let tvs = tyConTyVars tc
1062 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
1063 ; let name = reifyName tc
1064 r_tvs = reifyTyVars tvs
1065 deriv = [] -- Don't know about deriving
1066 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
1067 | otherwise = TH.DataD cxt name r_tvs cons deriv
1068 ; return (TH.TyConI decl) }
1070 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
1072 | isVanillaDataCon dc
1073 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
1074 ; let stricts = map reifyStrict (dataConStrictMarks dc)
1075 fields = dataConFieldLabels dc
1079 ; ASSERT( length arg_tys == length stricts )
1080 if not (null fields) then
1081 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
1083 if dataConIsInfix dc then
1084 ASSERT( length arg_tys == 2 )
1085 return (TH.InfixC (s1,a1) name (s2,a2))
1087 return (TH.NormalC name (stricts `zip` arg_tys)) }
1089 = failWithTc (ptext (sLit "Can't reify a GADT data constructor:")
1090 <+> quotes (ppr dc))
1092 ------------------------------
1093 reifyClass :: Class -> TcM TH.Info
1095 = do { cxt <- reifyCxt theta
1096 ; ops <- mapM reify_op op_stuff
1097 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
1099 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
1100 fds' = map reifyFunDep fds
1101 reify_op (op, _) = do { ty <- reifyType (idType op)
1102 ; return (TH.SigD (reifyName op) ty) }
1104 ------------------------------
1105 reifyType :: TypeRep.Type -> TcM TH.Type
1106 reifyType ty@(ForAllTy _ _) = reify_for_all ty
1107 reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
1108 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1109 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys -- Do not expand type synonyms here
1110 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1111 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1112 reifyType ty@(PredTy {}) = pprPanic "reifyType PredTy" (ppr ty)
1114 reify_for_all :: TypeRep.Type -> TcM TH.Type
1116 = do { cxt' <- reifyCxt cxt;
1117 ; tau' <- reifyType tau
1118 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
1120 (tvs, cxt, tau) = tcSplitSigmaTy ty
1122 reifyTypes :: [Type] -> TcM [TH.Type]
1123 reifyTypes = mapM reifyType
1125 reifyKind :: Kind -> TH.Kind
1127 = let (kis, ki') = splitKindFunTys ki
1128 kis_rep = map reifyKind kis
1129 ki'_rep = reifyNonArrowKind ki'
1131 foldr TH.ArrowK ki'_rep kis_rep
1133 reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
1134 | otherwise = pprPanic "Exotic form of kind"
1137 reifyCxt :: [PredType] -> TcM [TH.Pred]
1138 reifyCxt = mapM reifyPred
1140 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1141 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1143 reifyFamFlavour :: TyCon -> TH.FamFlavour
1144 reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
1145 | isOpenTyCon tc = TH.DataFam
1147 = panic "TcSplice.reifyFamFlavour: not a type family"
1149 reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
1150 reifyTyVars = map reifyTyVar
1152 reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV name
1153 | otherwise = TH.KindedTV name (reifyKind kind)
1158 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
1159 reify_tc_app tc tys = do { tys' <- reifyTypes tys
1160 ; return (foldl TH.AppT (TH.ConT tc) tys') }
1162 reifyPred :: TypeRep.PredType -> TcM TH.Pred
1163 reifyPred (ClassP cls tys)
1164 = do { tys' <- reifyTypes tys
1165 ; return $ TH.ClassP (reifyName cls) tys'
1167 reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
1168 reifyPred (EqPred ty1 ty2)
1169 = do { ty1' <- reifyType ty1
1170 ; ty2' <- reifyType ty2
1171 ; return $ TH.EqualP ty1' ty2'
1175 ------------------------------
1176 reifyName :: NamedThing n => n -> TH.Name
1178 | isExternalName name = mk_varg pkg_str mod_str occ_str
1179 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1180 -- Many of the things we reify have local bindings, and
1181 -- NameL's aren't supposed to appear in binding positions, so
1182 -- we use NameU. When/if we start to reify nested things, that
1183 -- have free variables, we may need to generate NameL's for them.
1185 name = getName thing
1186 mod = ASSERT( isExternalName name ) nameModule name
1187 pkg_str = packageIdString (modulePackageId mod)
1188 mod_str = moduleNameString (moduleName mod)
1189 occ_str = occNameString occ
1190 occ = nameOccName name
1191 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1192 | OccName.isVarOcc occ = TH.mkNameG_v
1193 | OccName.isTcOcc occ = TH.mkNameG_tc
1194 | otherwise = pprPanic "reifyName" (ppr name)
1196 ------------------------------
1197 reifyFixity :: Name -> TcM TH.Fixity
1199 = do { fix <- lookupFixityRn name
1200 ; return (conv_fix fix) }
1202 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1203 conv_dir BasicTypes.InfixR = TH.InfixR
1204 conv_dir BasicTypes.InfixL = TH.InfixL
1205 conv_dir BasicTypes.InfixN = TH.InfixN
1207 reifyStrict :: BasicTypes.HsBang -> TH.Strict
1208 reifyStrict bang | isBanged bang = TH.IsStrict
1209 | otherwise = TH.NotStrict
1211 ------------------------------
1212 noTH :: LitString -> SDoc -> TcM a
1213 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1214 ptext (sLit "in Template Haskell:"),