2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcSplice: Template Haskell splices
9 {-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket,
18 runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
20 #include "HsVersions.h"
24 -- These imports are the reason that TcSplice
25 -- is very high up the module hierarchy
61 import DsMonad hiding (Splice)
73 import qualified Language.Haskell.TH as TH
74 -- THSyntax gives access to internal functions and data types
75 import qualified Language.Haskell.TH.Syntax as TH
78 -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
79 import GHC.Desugar ( AnnotationWrapper(..) )
82 import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
83 import System.IO.Error
86 Note [Template Haskell levels]
87 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
88 * Imported things are impLevel (= 0)
90 * In GHCi, variables bound by a previous command are treated
91 as impLevel, because we have bytecode for them.
93 * Variables are bound at the "current level"
95 * The current level starts off at topLevel (= 1)
97 * The level is decremented by splicing $(..)
98 incremented by brackets [| |]
99 incremented by name-quoting 'f
101 When a variable is used, we compare
102 bind: binding level, and
103 use: current level at usage site
106 bind > use Always error (bound later than used)
109 bind = use Always OK (bound same stage as used)
110 [| \x -> $(f [| x |]) |]
112 bind < use Inside brackets, it depends
116 For (bind < use) inside brackets, there are three cases:
117 - Imported things OK f = [| map |]
118 - Top-level things OK g = [| f |]
119 - Non-top-level Only if there is a liftable instance
120 h = \(x:Int) -> [| x |]
122 See Note [What is a top-level Id?]
126 A quoted name 'n is a bit like a quoted expression [| n |], except that we
127 have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
128 the use-level to account for the brackets, the cases are:
137 See Note [What is a top-level Id?] in TcEnv. Examples:
139 f 'map -- OK; also for top-level defns of this module
141 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
142 -- cross-stage lifting
144 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
146 [| \x. $(f 'x) |] -- OK
149 Note [What is a top-level Id?]
150 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
151 In the level-control criteria above, we need to know what a "top level Id" is.
152 There are three kinds:
153 * Imported from another module (GlobalId, ExternalName)
154 * Bound at the top level of this module (ExternalName)
155 * In GHCi, bound by a previous stmt (GlobalId)
156 It's strange that there is no one criterion tht picks out all three, but that's
157 how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids
158 bound in an earlier Stmt, but what module would you choose? See
159 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
161 The predicate we use is TcEnv.thTopLevelId.
164 %************************************************************************
166 \subsection{Main interface + stubs for the non-GHCI case
168 %************************************************************************
171 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
172 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
173 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
174 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
175 -- None of these functions add constraints to the LIE
177 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
179 runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
180 runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
181 runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
184 tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
185 tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
186 tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
187 kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
189 lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
191 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
192 runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
193 runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
197 %************************************************************************
199 \subsection{Quoting an expression}
201 %************************************************************************
203 Note [Handling brackets]
204 ~~~~~~~~~~~~~~~~~~~~~~~~
205 Source: f = [| Just $(g 3) |]
206 The [| |] part is a HsBracket
208 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
209 The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
210 The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
212 Desugared: f = do { s7 <- g Int 3
213 ; return (ConE "Data.Maybe.Just" s7) }
216 tcBracket brack res_ty = do
218 case bracketOK level of {
219 Nothing -> failWithTc (illegalBracket level) ;
220 Just next_level -> do
222 -- Typecheck expr to make sure it is valid,
223 -- but throw away the results. We'll type check
224 -- it again when we actually use it.
226 pending_splices <- newMutVar []
229 (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
230 (getLIE (tc_bracket next_level brack))
231 tcSimplifyBracket lie
233 -- Make the expected type have the right shape
234 boxyUnify meta_ty res_ty
236 -- Return the original expression, not the type-decorated one
237 pendings <- readMutVar pending_splices
238 return (noLoc (HsBracketOut brack pendings))
241 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
242 tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
243 = do { thing <- tcLookup name
245 AGlobal _ -> return ()
246 ATcId { tct_level = bind_lvl, tct_id = id }
247 | thTopLevelId id -- C.f thTopLevelId case of
248 -> keepAliveTc id -- TcExpr.thBrackId
250 -> do { checkTc (use_lvl == bind_lvl)
251 (quotedNameStageErr name) }
252 _ -> pprPanic "th_bracket" (ppr name)
254 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
257 tc_bracket _ (ExpBr expr)
258 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
259 ; tcMonoExpr expr any_ty
260 ; tcMetaTy expQTyConName }
261 -- Result type is Expr (= Q Exp)
263 tc_bracket _ (TypBr typ)
264 = do { tcHsSigType ExprSigCtxt typ
265 ; tcMetaTy typeQTyConName }
266 -- Result type is Type (= Q Typ)
268 tc_bracket _ (DecBr decls)
269 = do { tcTopSrcDecls emptyModDetails decls
270 -- Typecheck the declarations, dicarding the result
271 -- We'll get all that stuff later, when we splice it in
273 ; decl_ty <- tcMetaTy decTyConName
274 ; q_ty <- tcMetaTy qTyConName
275 ; return (mkAppTy q_ty (mkListTy decl_ty))
276 -- Result type is Q [Dec]
279 tc_bracket _ (PatBr _)
280 = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
282 quotedNameStageErr :: Name -> SDoc
284 = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
285 , ptext (sLit "must be used at the same stage at which is is bound")]
289 %************************************************************************
291 \subsection{Splicing an expression}
293 %************************************************************************
296 tcSpliceExpr (HsSplice name expr) res_ty
297 = setSrcSpan (getLoc expr) $ do
299 case spliceOK level of {
300 Nothing -> failWithTc (illegalSplice level) ;
304 Comp _ -> do { e <- tcTopSplice expr res_ty
305 ; return (unLoc e) } ;
306 Brack _ ps_var lie_var -> do
308 -- A splice inside brackets
309 -- NB: ignore res_ty, apart from zapping it to a mono-type
310 -- e.g. [| reverse $(h 4) |]
311 -- Here (h 4) :: Q Exp
312 -- but $(h 4) :: forall a.a i.e. anything!
315 meta_exp_ty <- tcMetaTy expQTyConName
316 expr' <- setStage (Splice next_level) (
318 tcMonoExpr expr meta_exp_ty
321 -- Write the pending splice into the bucket
322 ps <- readMutVar ps_var
323 writeMutVar ps_var ((name,expr') : ps)
325 return (panic "tcSpliceExpr") -- The returned expression is ignored
327 ; Splice {} -> panic "tcSpliceExpr Splice"
330 -- tcTopSplice used to have this:
331 -- Note that we do not decrement the level (to -1) before
332 -- typechecking the expression. For example:
333 -- f x = $( ...$(g 3) ... )
334 -- The recursive call to tcMonoExpr will simply expand the
335 -- inner escape before dealing with the outer one
337 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
338 tcTopSplice expr res_ty = do
339 meta_exp_ty <- tcMetaTy expQTyConName
341 -- Typecheck the expression
342 zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
344 -- Run the expression
345 traceTc (text "About to run" <+> ppr zonked_q_expr)
346 expr2 <- runMetaE convertToHsExpr zonked_q_expr
348 traceTc (text "Got result" <+> ppr expr2)
350 showSplice "expression"
351 zonked_q_expr (ppr expr2)
353 -- Rename it, but bale out if there are errors
354 -- otherwise the type checker just gives more spurious errors
355 (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
357 tcMonoExpr exp3 res_ty
360 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
361 -- Type check an expression that is the body of a top-level splice
362 -- (the caller will compile and run it)
363 tcTopSpliceExpr expr meta_ty
364 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
365 -- if the type checker fails!
366 do { (expr', const_binds) <- tcSimplifyStagedExpr topSpliceStage $
367 (recordThUse >> tcMonoExpr expr meta_ty)
368 -- Zonk it and tie the knot of dictionary bindings
369 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
373 %************************************************************************
377 %************************************************************************
380 runAnnotation target expr = do
381 expr_ty <- newFlexiTyVarTy liftedTypeKind
383 -- Find the classes we want instances for in order to call toAnnotationWrapper
384 data_class <- tcLookupClass dataClassName
386 -- Check the instances we require live in another module (we want to execute it..)
387 -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
388 -- also resolves the LIE constraints to detect e.g. instance ambiguity
389 ((wrapper, expr'), const_binds) <- tcSimplifyStagedExpr topAnnStage $ do
390 expr' <- tcPolyExprNC expr expr_ty
391 -- By instantiating the call >here< it gets registered in the
392 -- LIE consulted by tcSimplifyStagedExpr
393 -- and hence ensures the appropriate dictionary is bound by const_binds
394 wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
395 return (wrapper, expr')
397 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
399 to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
400 let specialised_to_annotation_wrapper_expr = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
401 wrapped_expr' = mkHsDictLet const_binds $
402 L loc (HsApp specialised_to_annotation_wrapper_expr expr')
404 -- If we have type checking problems then potentially zonking
405 -- (and certainly compilation) may fail. Give up NOW!
408 -- Zonk the type variables out of that raw expression. Note that
409 -- in particular we don't call recordThUse, since we don't
410 -- necessarily use any code or definitions from that package.
411 zonked_wrapped_expr' <- zonkTopLExpr wrapped_expr'
413 -- Run the appropriately wrapped expression to get the value of
414 -- the annotation and its dictionaries. The return value is of
415 -- type AnnotationWrapper by construction, so this conversion is
417 flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper ->
418 case annotation_wrapper of
419 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
420 -- Got the value and dictionaries: build the serialized value and
421 -- call it a day. We ensure that we seq the entire serialized value
422 -- in order that any errors in the user-written code for the
423 -- annotation are exposed at this point. This is also why we are
424 -- doing all this stuff inside the context of runMeta: it has the
425 -- facilities to deal with user error in a meta-level expression
426 seqSerialized serialized `seq` Annotation {
428 ann_value = serialized
433 %************************************************************************
437 %************************************************************************
439 Note [Quasi-quote overview]
440 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
441 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
442 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
447 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
448 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
449 defined in another module, because we are going to run it here. It's
450 a bit like a TH splice:
453 However, you can do this in patterns as well as terms. Becuase of this,
454 the splice is run by the *renamer* rather than the type checker.
457 runQuasiQuote :: Outputable hs_syn
458 => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
459 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
460 -> String -- Documentation string only
461 -> Name -- Name of th_syn type
462 -> (SrcSpan -> th_syn -> Either Message hs_syn)
464 runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
465 = do { -- Check that the quoter is not locally defined, otherwise the TH
466 -- machinery will not be able to run the quasiquote.
467 ; this_mod <- getModule
468 ; let is_local = case nameModule_maybe quoter of
469 Just mod | mod == this_mod -> True
472 ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
473 ; checkTc (not is_local) (quoteStageError quoter)
475 -- Build the expression
476 ; let quoterExpr = L q_span $! HsVar $! quoter
477 ; let quoteExpr = L q_span $! HsLit $! HsString quote
478 ; let expr = L q_span $
480 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
482 ; meta_exp_ty <- tcMetaTy meta_ty
484 -- Typecheck the expression
485 ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
487 -- Run the expression
488 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
489 ; result <- runMetaQ convert zonked_q_expr
490 ; traceTc (text "Got result" <+> ppr result)
491 ; showSplice desc zonked_q_expr (ppr result)
495 runQuasiQuoteExpr quasiquote
496 = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
498 runQuasiQuotePat quasiquote
499 = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
501 quoteStageError :: Name -> SDoc
502 quoteStageError quoter
503 = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
504 nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
508 %************************************************************************
512 %************************************************************************
514 Very like splicing an expression, but we don't yet share code.
517 kcSpliceType (HsSplice name hs_expr)
518 = setSrcSpan (getLoc hs_expr) $ do
520 ; case spliceOK level of {
521 Nothing -> failWithTc (illegalSplice level) ;
522 Just next_level -> do
525 Comp _ -> do { (t,k) <- kcTopSpliceType hs_expr
526 ; return (unLoc t, k) } ;
527 Brack _ ps_var lie_var -> do
529 { -- A splice inside brackets
530 ; meta_ty <- tcMetaTy typeQTyConName
531 ; expr' <- setStage (Splice next_level) $
533 tcMonoExpr hs_expr meta_ty
535 -- Write the pending splice into the bucket
536 ; ps <- readMutVar ps_var
537 ; writeMutVar ps_var ((name,expr') : ps)
539 -- e.g. [| Int -> $(h 4) |]
540 -- Here (h 4) :: Q Type
541 -- but $(h 4) :: forall a.a i.e. any kind
543 ; return (panic "kcSpliceType", kind) -- The returned type is ignored
545 ; Splice {} -> panic "kcSpliceType Splice"
548 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
550 = do { meta_ty <- tcMetaTy typeQTyConName
552 -- Typecheck the expression
553 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
555 -- Run the expression
556 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
557 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
559 ; traceTc (text "Got result" <+> ppr hs_ty2)
561 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
563 -- Rename it, but bale out if there are errors
564 -- otherwise the type checker just gives more spurious errors
565 ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
566 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
571 %************************************************************************
573 \subsection{Splicing an expression}
575 %************************************************************************
578 -- Always at top level
579 -- Type sig at top of file:
580 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
582 = do { meta_dec_ty <- tcMetaTy decTyConName
583 ; meta_q_ty <- tcMetaTy qTyConName
584 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
585 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
587 -- Run the expression
588 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
589 ; decls <- runMetaD convertToHsDecls zonked_q_expr
591 ; traceTc (text "Got result" <+> vcat (map ppr decls))
592 ; showSplice "declarations"
594 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
599 %************************************************************************
601 \subsection{Running an expression}
603 %************************************************************************
606 runMetaAW :: (AnnotationWrapper -> output)
607 -> LHsExpr Id -- Of type AnnotationWrapper
609 runMetaAW k = runMeta False (\_ -> return . Right . k)
610 -- We turn off showing the code in meta-level exceptions because doing so exposes
611 -- the toAnnotationWrapper function that we slap around the users code
613 runQThen :: (SrcSpan -> input -> Either Message output)
616 -> TcM (Either Message output)
617 runQThen f expr_span what = TH.runQ what >>= (return . f expr_span)
619 runMetaQ :: (SrcSpan -> input -> Either Message output)
622 runMetaQ = runMeta True . runQThen
624 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
625 -> LHsExpr Id -- Of type (Q Exp)
626 -> TcM (LHsExpr RdrName)
629 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
630 -> LHsExpr Id -- Of type (Q Pat)
634 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
635 -> LHsExpr Id -- Of type (Q Type)
636 -> TcM (LHsType RdrName)
639 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
640 -> LHsExpr Id -- Of type Q [Dec]
641 -> TcM [LHsDecl RdrName]
644 runMeta :: Bool -- Whether code should be printed in the exception message
645 -> (SrcSpan -> input -> TcM (Either Message output))
646 -> LHsExpr Id -- Of type X
647 -> TcM output -- Of type t
648 runMeta show_code run_and_convert expr
650 ds_expr <- initDsTc (dsLExpr expr)
651 -- Compile and link it; might fail if linking fails
652 ; hsc_env <- getTopEnv
653 ; src_span <- getSrcSpanM
654 ; either_hval <- tryM $ liftIO $
655 HscMain.compileExpr hsc_env src_span ds_expr
656 ; case either_hval of {
657 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
660 { -- Coerce it to Q t, and run it
662 -- Running might fail if it throws an exception of any kind (hence tryAllM)
663 -- including, say, a pattern-match exception in the code we are running
665 -- We also do the TH -> HS syntax conversion inside the same
666 -- exception-cacthing thing so that if there are any lurking
667 -- exceptions in the data structure returned by hval, we'll
668 -- encounter them inside the try
670 -- See Note [Exceptions in TH]
671 let expr_span = getLoc expr
672 ; either_tval <- tryAllM $
673 setSrcSpan expr_span $ -- Set the span so that qLocation can
674 -- see where this splice is
675 do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
677 Left err -> failWithTc err
678 Right result -> return $! result }
680 ; case either_tval of
683 case fromException se of
685 failM -- Error already in Tc monad
686 _ -> failWithTc (mk_msg "run" se) -- Exception
689 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
690 nest 2 (text (Panic.showException exn)),
691 if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
694 Note [Exceptions in TH]
695 ~~~~~~~~~~~~~~~~~~~~~~~
696 Supppose we have something like this
700 f n | n>3 = fail "Too many declarations"
703 The 'fail' is a user-generated failure, and should be displayed as a
704 perfectly ordinary compiler error message, not a panic or anything
705 like that. Here's how it's processed:
707 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
708 effectively transforms (fail s) to
709 qReport True s >> fail
710 where 'qReport' comes from the Quasi class and fail from its monad
713 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
714 (qReport True s) by using addErr to add an error message to the bag of errors.
715 The 'fail' in TcM raises an IOEnvFailure exception
717 * So, when running a splice, we catch all exceptions; then for
718 - an IOEnvFailure exception, we assume the error is already
719 in the error-bag (above)
720 - other errors, we add an error to the bag
724 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
727 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
728 qNewName s = do { u <- newUnique
730 ; return (TH.mkNameU s i) }
732 qReport True msg = addErr (text msg)
733 qReport False msg = addReport (text msg)
735 qLocation = do { m <- getModule
737 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
738 , TH.loc_module = moduleNameString (moduleName m)
739 , TH.loc_package = packageIdString (modulePackageId m)
740 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
741 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
745 -- For qRecover, discard error messages if
746 -- the recovery action is chosen. Otherwise
747 -- we'll only fail higher up. c.f. tryTcLIE_
748 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
750 Just val -> do { addMessages msgs -- There might be warnings
752 Nothing -> recover -- Discard all msgs
755 qRunIO io = liftIO io
759 %************************************************************************
761 \subsection{Errors and contexts}
763 %************************************************************************
766 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
767 showSplice what before after = do
769 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
770 nest 2 (sep [nest 2 (ppr before),
774 illegalBracket :: ThStage -> SDoc
776 = ptext (sLit "Illegal bracket at level") <+> ppr level
778 illegalSplice :: ThStage -> SDoc
780 = ptext (sLit "Illegal splice at level") <+> ppr level
786 %************************************************************************
790 %************************************************************************
794 reify :: TH.Name -> TcM TH.Info
796 = do { name <- lookupThName th_name
797 ; thing <- tcLookupTh name
798 -- ToDo: this tcLookup could fail, which would give a
799 -- rather unhelpful error message
800 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
804 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
805 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
806 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
807 ppr_ns _ = panic "reify/ppr_ns"
809 lookupThName :: TH.Name -> TcM Name
810 lookupThName th_name = do
811 mb_name <- lookupThName_maybe th_name
813 Nothing -> failWithTc (notInScope th_name)
814 Just name -> return name
816 lookupThName_maybe th_name
817 = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
818 -- Pick the first that works
819 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
820 ; return (listToMaybe names) }
823 = do { -- Repeat much of lookupOccRn, becase we want
824 -- to report errors in a TH-relevant way
825 ; rdr_env <- getLocalRdrEnv
826 ; case lookupLocalRdrEnv rdr_env rdr_name of
827 Just name -> return (Just name)
828 Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
829 -> do { name <- lookupImportedName rdr_name
830 ; return (Just name) }
831 | otherwise -- Unqual, Qual
832 -> lookupSrcOcc_maybe rdr_name }
834 tcLookupTh :: Name -> TcM TcTyThing
835 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
836 -- it gives a reify-related error message on failure, whereas in the normal
837 -- tcLookup, failure is a bug.
839 = do { (gbl_env, lcl_env) <- getEnvs
840 ; case lookupNameEnv (tcl_env lcl_env) name of {
841 Just thing -> return thing;
843 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
844 then -- It's defined in this module
845 case lookupNameEnv (tcg_type_env gbl_env) name of
846 Just thing -> return (AGlobal thing)
847 Nothing -> failWithTc (notInEnv name)
849 else do -- It's imported
850 { (eps,hpt) <- getEpsAndHpt
852 ; case lookupType dflags hpt (eps_PTE eps) name of
853 Just thing -> return (AGlobal thing)
854 Nothing -> do { thing <- tcImportDecl name
855 ; return (AGlobal thing) }
856 -- Imported names should always be findable;
857 -- if not, we fail hard in tcImportDecl
860 notInScope :: TH.Name -> SDoc
861 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
862 ptext (sLit "is not in scope at a reify")
863 -- Ugh! Rather an indirect way to display the name
865 notInEnv :: Name -> SDoc
866 notInEnv name = quotes (ppr name) <+>
867 ptext (sLit "is not in the type environment at a reify")
869 ------------------------------
870 reifyThing :: TcTyThing -> TcM TH.Info
871 -- The only reason this is monadic is for error reporting,
872 -- which in turn is mainly for the case when TH can't express
873 -- some random GHC extension
875 reifyThing (AGlobal (AnId id))
876 = do { ty <- reifyType (idType id)
877 ; fix <- reifyFixity (idName id)
878 ; let v = reifyName id
879 ; case globalIdDetails id of
880 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
881 _ -> return (TH.VarI v ty Nothing fix)
884 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
885 reifyThing (AGlobal (AClass cls)) = reifyClass cls
886 reifyThing (AGlobal (ADataCon dc))
887 = do { let name = dataConName dc
888 ; ty <- reifyType (idType (dataConWrapId dc))
889 ; fix <- reifyFixity name
890 ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
892 reifyThing (ATcId {tct_id = id, tct_type = ty})
893 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
894 -- though it may be incomplete
895 ; ty2 <- reifyType ty1
896 ; fix <- reifyFixity (idName id)
897 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
899 reifyThing (ATyVar tv ty)
900 = do { ty1 <- zonkTcType ty
901 ; ty2 <- reifyType ty1
902 ; return (TH.TyVarI (reifyName tv) ty2) }
904 reifyThing (AThing {}) = panic "reifyThing AThing"
906 ------------------------------
907 reifyTyCon :: TyCon -> TcM TH.Info
909 | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
910 | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
912 = do { let (tvs, rhs) = synTyConDefn tc
913 ; rhs' <- reifyType rhs
914 ; return (TH.TyConI $
915 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
918 = do { cxt <- reifyCxt (tyConStupidTheta tc)
919 ; let tvs = tyConTyVars tc
920 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
921 ; let name = reifyName tc
922 r_tvs = reifyTyVars tvs
923 deriv = [] -- Don't know about deriving
924 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
925 | otherwise = TH.DataD cxt name r_tvs cons deriv
926 ; return (TH.TyConI decl) }
928 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
930 | isVanillaDataCon dc
931 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
932 ; let stricts = map reifyStrict (dataConStrictMarks dc)
933 fields = dataConFieldLabels dc
937 ; ASSERT( length arg_tys == length stricts )
938 if not (null fields) then
939 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
941 if dataConIsInfix dc then
942 ASSERT( length arg_tys == 2 )
943 return (TH.InfixC (s1,a1) name (s2,a2))
945 return (TH.NormalC name (stricts `zip` arg_tys)) }
947 = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:")
950 ------------------------------
951 reifyClass :: Class -> TcM TH.Info
953 = do { cxt <- reifyCxt theta
954 ; ops <- mapM reify_op op_stuff
955 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
957 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
958 fds' = map reifyFunDep fds
959 reify_op (op, _) = do { ty <- reifyType (idType op)
960 ; return (TH.SigD (reifyName op) ty) }
962 ------------------------------
963 reifyType :: TypeRep.Type -> TcM TH.Type
964 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
965 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
966 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
967 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
968 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
969 ; tau' <- reifyType tau
970 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
972 (tvs, cxt, tau) = tcSplitSigmaTy ty
973 reifyType (PredTy {}) = panic "reifyType PredTy"
975 reifyTypes :: [Type] -> TcM [TH.Type]
976 reifyTypes = mapM reifyType
977 reifyCxt :: [PredType] -> TcM [TH.Type]
978 reifyCxt = mapM reifyPred
980 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
981 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
983 reifyTyVars :: [TyVar] -> [TH.Name]
984 reifyTyVars = map reifyName
986 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
987 reify_tc_app tc tys = do { tys' <- reifyTypes tys
988 ; return (foldl TH.AppT (TH.ConT tc) tys') }
990 reifyPred :: TypeRep.PredType -> TcM TH.Type
991 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
992 reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
993 reifyPred (EqPred {}) = panic "reifyPred EqPred"
996 ------------------------------
997 reifyName :: NamedThing n => n -> TH.Name
999 | isExternalName name = mk_varg pkg_str mod_str occ_str
1000 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1001 -- Many of the things we reify have local bindings, and
1002 -- NameL's aren't supposed to appear in binding positions, so
1003 -- we use NameU. When/if we start to reify nested things, that
1004 -- have free variables, we may need to generate NameL's for them.
1006 name = getName thing
1007 mod = ASSERT( isExternalName name ) nameModule name
1008 pkg_str = packageIdString (modulePackageId mod)
1009 mod_str = moduleNameString (moduleName mod)
1010 occ_str = occNameString occ
1011 occ = nameOccName name
1012 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1013 | OccName.isVarOcc occ = TH.mkNameG_v
1014 | OccName.isTcOcc occ = TH.mkNameG_tc
1015 | otherwise = pprPanic "reifyName" (ppr name)
1017 ------------------------------
1018 reifyFixity :: Name -> TcM TH.Fixity
1020 = do { fix <- lookupFixityRn name
1021 ; return (conv_fix fix) }
1023 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1024 conv_dir BasicTypes.InfixR = TH.InfixR
1025 conv_dir BasicTypes.InfixL = TH.InfixL
1026 conv_dir BasicTypes.InfixN = TH.InfixN
1028 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
1029 reifyStrict MarkedStrict = TH.IsStrict
1030 reifyStrict MarkedUnboxed = TH.IsStrict
1031 reifyStrict NotMarkedStrict = TH.NotStrict
1033 ------------------------------
1034 noTH :: LitString -> SDoc -> TcM a
1035 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1036 ptext (sLit "in Template Haskell:"),