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,
17 runQuasiQuoteExpr, runQuasiQuotePat ) where
19 #include "HsVersions.h"
23 -- These imports are the reason that TcSplice
24 -- is very high up the module hierarchy
57 import DsMonad hiding (Splice)
68 import qualified Language.Haskell.TH as TH
69 -- THSyntax gives access to internal functions and data types
70 import qualified Language.Haskell.TH.Syntax as TH
72 import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
73 import System.IO.Error
76 Note [Template Haskell levels]
77 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
78 * Imported things are impLevel (= 0)
80 * In GHCi, variables bound by a previous command are treated
81 as impLevel, because we have bytecode for them.
83 * Variables are bound at the "current level"
85 * The current level starts off at topLevel (= 1)
87 * The level is decremented by splicing $(..)
88 incremented by brackets [| |]
89 incremented by name-quoting 'f
91 When a variable is used, we compare
92 bind: binding level, and
93 use: current level at usage site
96 bind > use Always error (bound later than used)
99 bind = use Always OK (bound same stage as used)
100 [| \x -> $(f [| x |]) |]
102 bind < use Inside brackets, it depends
106 For (bind < use) inside brackets, there are three cases:
107 - Imported things OK f = [| map |]
108 - Top-level things OK g = [| f |]
109 - Non-top-level Only if there is a liftable instance
110 h = \(x:Int) -> [| x |]
112 See Note [What is a top-level Id?]
116 A quoted name 'n is a bit like a quoted expression [| n |], except that we
117 have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
118 the use-level to account for the brackets, the cases are:
127 See Note [What is a top-level Id?] in TcEnv. Examples:
129 f 'map -- OK; also for top-level defns of this module
131 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
132 -- cross-stage lifting
134 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
136 [| \x. $(f 'x) |] -- OK
139 Note [What is a top-level Id?]
140 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
141 In the level-control criteria above, we need to know what a "top level Id" is.
142 There are three kinds:
143 * Imported from another module (GlobalId, ExternalName)
144 * Bound at the top level of this module (ExternalName)
145 * In GHCi, bound by a previous stmt (GlobalId)
146 It's strange that there is no one criterion tht picks out all three, but that's
147 how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids
148 bound in an earlier Stmt, but what module would you choose? See
149 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
151 The predicate we use is TcEnv.thTopLevelId.
154 %************************************************************************
156 \subsection{Main interface + stubs for the non-GHCI case
158 %************************************************************************
161 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
162 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
163 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
164 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
165 -- None of these functions add constraints to the LIE
167 runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
168 runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
171 tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
172 tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
173 tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
174 kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
176 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
177 runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
181 %************************************************************************
183 \subsection{Quoting an expression}
185 %************************************************************************
187 Note [Handling brackets]
188 ~~~~~~~~~~~~~~~~~~~~~~~~
189 Source: f = [| Just $(g 3) |]
190 The [| |] part is a HsBracket
192 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
193 The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
194 The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
196 Desugared: f = do { s7 <- g Int 3
197 ; return (ConE "Data.Maybe.Just" s7) }
200 tcBracket brack res_ty = do
202 case bracketOK level of {
203 Nothing -> failWithTc (illegalBracket level) ;
204 Just next_level -> do
206 -- Typecheck expr to make sure it is valid,
207 -- but throw away the results. We'll type check
208 -- it again when we actually use it.
210 pending_splices <- newMutVar []
213 (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
214 (getLIE (tc_bracket next_level brack))
215 tcSimplifyBracket lie
217 -- Make the expected type have the right shape
218 boxyUnify meta_ty res_ty
220 -- Return the original expression, not the type-decorated one
221 pendings <- readMutVar pending_splices
222 return (noLoc (HsBracketOut brack pendings))
225 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
226 tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
227 = do { thing <- tcLookup name
229 AGlobal _ -> return ()
230 ATcId { tct_level = bind_lvl, tct_id = id }
231 | thTopLevelId id -- C.f thTopLevelId case of
232 -> keepAliveTc id -- TcExpr.thBrackId
234 -> do { checkTc (use_lvl == bind_lvl)
235 (quotedNameStageErr name) }
236 _ -> pprPanic "th_bracket" (ppr name)
238 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
241 tc_bracket _ (ExpBr expr)
242 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
243 ; tcMonoExpr expr any_ty
244 ; tcMetaTy expQTyConName }
245 -- Result type is Expr (= Q Exp)
247 tc_bracket _ (TypBr typ)
248 = do { tcHsSigType ExprSigCtxt typ
249 ; tcMetaTy typeQTyConName }
250 -- Result type is Type (= Q Typ)
252 tc_bracket _ (DecBr decls)
253 = do { tcTopSrcDecls emptyModDetails decls
254 -- Typecheck the declarations, dicarding the result
255 -- We'll get all that stuff later, when we splice it in
257 ; decl_ty <- tcMetaTy decTyConName
258 ; q_ty <- tcMetaTy qTyConName
259 ; return (mkAppTy q_ty (mkListTy decl_ty))
260 -- Result type is Q [Dec]
263 tc_bracket _ (PatBr _)
264 = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
266 quotedNameStageErr :: Name -> SDoc
268 = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
269 , ptext (sLit "must be used at the same stage at which is is bound")]
273 %************************************************************************
275 \subsection{Splicing an expression}
277 %************************************************************************
280 tcSpliceExpr (HsSplice name expr) res_ty
281 = setSrcSpan (getLoc expr) $ do
283 case spliceOK level of {
284 Nothing -> failWithTc (illegalSplice level) ;
288 Comp -> do { e <- tcTopSplice expr res_ty
289 ; return (unLoc e) } ;
290 Brack _ ps_var lie_var -> do
292 -- A splice inside brackets
293 -- NB: ignore res_ty, apart from zapping it to a mono-type
294 -- e.g. [| reverse $(h 4) |]
295 -- Here (h 4) :: Q Exp
296 -- but $(h 4) :: forall a.a i.e. anything!
299 meta_exp_ty <- tcMetaTy expQTyConName
300 expr' <- setStage (Splice next_level) (
302 tcMonoExpr expr meta_exp_ty
305 -- Write the pending splice into the bucket
306 ps <- readMutVar ps_var
307 writeMutVar ps_var ((name,expr') : ps)
309 return (panic "tcSpliceExpr") -- The returned expression is ignored
311 ; Splice {} -> panic "tcSpliceExpr Splice"
314 -- tcTopSplice used to have this:
315 -- Note that we do not decrement the level (to -1) before
316 -- typechecking the expression. For example:
317 -- f x = $( ...$(g 3) ... )
318 -- The recursive call to tcMonoExpr will simply expand the
319 -- inner escape before dealing with the outer one
321 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
322 tcTopSplice expr res_ty = do
323 meta_exp_ty <- tcMetaTy expQTyConName
325 -- Typecheck the expression
326 zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
328 -- Run the expression
329 traceTc (text "About to run" <+> ppr zonked_q_expr)
330 expr2 <- runMetaE convertToHsExpr zonked_q_expr
332 traceTc (text "Got result" <+> ppr expr2)
334 showSplice "expression"
335 zonked_q_expr (ppr expr2)
337 -- Rename it, but bale out if there are errors
338 -- otherwise the type checker just gives more spurious errors
339 (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
341 tcMonoExpr exp3 res_ty
344 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
345 -- Type check an expression that is the body of a top-level splice
346 -- (the caller will compile and run it)
347 tcTopSpliceExpr expr meta_ty
348 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
349 -- if the type checker fails!
351 setStage topSpliceStage $ do
354 do { recordThUse -- Record that TH is used (for pkg depdendency)
356 -- Typecheck the expression
357 ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
359 -- Solve the constraints
360 ; const_binds <- tcSimplifyTop lie
363 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
367 %************************************************************************
371 %************************************************************************
373 Note [Quasi-quote overview]
374 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
375 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
376 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
381 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
382 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
383 defined in another module, because we are going to run it here. It's
384 a bit like a TH splice:
387 However, you can do this in patterns as well as terms. Becuase of this,
388 the splice is run by the *renamer* rather than the type checker.
391 runQuasiQuote :: Outputable hs_syn
392 => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
393 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
394 -> String -- Documentation string only
395 -> Name -- Name of th_syn type
396 -> (SrcSpan -> th_syn -> Either Message hs_syn)
398 runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
399 = do { -- Check that the quoter is not locally defined, otherwise the TH
400 -- machinery will not be able to run the quasiquote.
401 ; this_mod <- getModule
402 ; let is_local = case nameModule_maybe quoter of
403 Just mod | mod == this_mod -> True
406 ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
407 ; checkTc (not is_local) (quoteStageError quoter)
409 -- Build the expression
410 ; let quoterExpr = L q_span $! HsVar $! quoter
411 ; let quoteExpr = L q_span $! HsLit $! HsString quote
412 ; let expr = L q_span $
414 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
416 ; meta_exp_ty <- tcMetaTy meta_ty
418 -- Typecheck the expression
419 ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
421 -- Run the expression
422 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
423 ; result <- runMeta convert zonked_q_expr
424 ; traceTc (text "Got result" <+> ppr result)
425 ; showSplice desc zonked_q_expr (ppr result)
429 runQuasiQuoteExpr quasiquote
430 = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
432 runQuasiQuotePat quasiquote
433 = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
435 quoteStageError :: Name -> SDoc
436 quoteStageError quoter
437 = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
438 nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
442 %************************************************************************
446 %************************************************************************
448 Very like splicing an expression, but we don't yet share code.
451 kcSpliceType (HsSplice name hs_expr)
452 = setSrcSpan (getLoc hs_expr) $ do
454 ; case spliceOK level of {
455 Nothing -> failWithTc (illegalSplice level) ;
456 Just next_level -> do
459 Comp -> do { (t,k) <- kcTopSpliceType hs_expr
460 ; return (unLoc t, k) } ;
461 Brack _ ps_var lie_var -> do
463 { -- A splice inside brackets
464 ; meta_ty <- tcMetaTy typeQTyConName
465 ; expr' <- setStage (Splice next_level) $
467 tcMonoExpr hs_expr meta_ty
469 -- Write the pending splice into the bucket
470 ; ps <- readMutVar ps_var
471 ; writeMutVar ps_var ((name,expr') : ps)
473 -- e.g. [| Int -> $(h 4) |]
474 -- Here (h 4) :: Q Type
475 -- but $(h 4) :: forall a.a i.e. any kind
477 ; return (panic "kcSpliceType", kind) -- The returned type is ignored
479 ; Splice {} -> panic "kcSpliceType Splice"
482 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
484 = do { meta_ty <- tcMetaTy typeQTyConName
486 -- Typecheck the expression
487 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
489 -- Run the expression
490 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
491 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
493 ; traceTc (text "Got result" <+> ppr hs_ty2)
495 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
497 -- Rename it, but bale out if there are errors
498 -- otherwise the type checker just gives more spurious errors
499 ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
500 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
505 %************************************************************************
507 \subsection{Splicing an expression}
509 %************************************************************************
512 -- Always at top level
513 -- Type sig at top of file:
514 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
516 = do { meta_dec_ty <- tcMetaTy decTyConName
517 ; meta_q_ty <- tcMetaTy qTyConName
518 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
519 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
521 -- Run the expression
522 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
523 ; decls <- runMetaD convertToHsDecls zonked_q_expr
525 ; traceTc (text "Got result" <+> vcat (map ppr decls))
526 ; showSplice "declarations"
528 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
533 %************************************************************************
535 \subsection{Running an expression}
537 %************************************************************************
540 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
541 -> LHsExpr Id -- Of type (Q Exp)
542 -> TcM (LHsExpr RdrName)
545 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
546 -> LHsExpr Id -- Of type (Q Pat)
550 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
551 -> LHsExpr Id -- Of type (Q Type)
552 -> TcM (LHsType RdrName)
555 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
556 -> LHsExpr Id -- Of type Q [Dec]
557 -> TcM [LHsDecl RdrName]
560 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
561 -> LHsExpr Id -- Of type X
562 -> TcM hs_syn -- Of type t
565 ds_expr <- initDsTc (dsLExpr expr)
566 -- Compile and link it; might fail if linking fails
567 ; hsc_env <- getTopEnv
568 ; src_span <- getSrcSpanM
569 ; either_hval <- tryM $ liftIO $
570 HscMain.compileExpr hsc_env src_span ds_expr
571 ; case either_hval of {
572 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
575 { -- Coerce it to Q t, and run it
577 -- Running might fail if it throws an exception of any kind (hence tryAllM)
578 -- including, say, a pattern-match exception in the code we are running
580 -- We also do the TH -> HS syntax conversion inside the same
581 -- exception-cacthing thing so that if there are any lurking
582 -- exceptions in the data structure returned by hval, we'll
583 -- encounter them inside the try
585 -- See Note [Exceptions in TH]
586 let expr_span = getLoc expr
587 ; either_tval <- tryAllM $
588 setSrcSpan expr_span $ -- Set the span so that qLocation can
589 -- see where this splice is
590 do { th_syn <- TH.runQ (unsafeCoerce# hval)
591 ; case convert expr_span th_syn of
592 Left err -> failWithTc err
593 Right hs_syn -> return hs_syn }
595 ; case either_tval of
598 case fromException se of
600 failM -- Error already in Tc monad
601 _ -> failWithTc (mk_msg "run" se) -- Exception
604 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
605 nest 2 (text (Panic.showException exn)),
606 nest 2 (text "Code:" <+> ppr expr)]
609 Note [Exceptions in TH]
610 ~~~~~~~~~~~~~~~~~~~~~~~
611 Supppose we have something like this
615 f n | n>3 = fail "Too many declarations"
618 The 'fail' is a user-generated failure, and should be displayed as a
619 perfectly ordinary compiler error message, not a panic or anything
620 like that. Here's how it's processed:
622 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
623 effectively transforms (fail s) to
624 qReport True s >> fail
625 where 'qReport' comes from the Quasi class and fail from its monad
628 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
629 (qReport True s) by using addErr to add an error message to the bag of errors.
630 The 'fail' in TcM raises an IOEnvFailure exception
632 * So, when running a splice, we catch all exceptions; then for
633 - an IOEnvFailure exception, we assume the error is already
634 in the error-bag (above)
635 - other errors, we add an error to the bag
639 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
642 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
643 qNewName s = do { u <- newUnique
645 ; return (TH.mkNameU s i) }
647 qReport True msg = addErr (text msg)
648 qReport False msg = addReport (text msg)
650 qLocation = do { m <- getModule
652 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
653 , TH.loc_module = moduleNameString (moduleName m)
654 , TH.loc_package = packageIdString (modulePackageId m)
655 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
656 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
660 -- For qRecover, discard error messages if
661 -- the recovery action is chosen. Otherwise
662 -- we'll only fail higher up. c.f. tryTcLIE_
663 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
665 Just val -> do { addMessages msgs -- There might be warnings
667 Nothing -> recover -- Discard all msgs
670 qRunIO io = liftIO io
674 %************************************************************************
676 \subsection{Errors and contexts}
678 %************************************************************************
681 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
682 showSplice what before after = do
684 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
685 nest 2 (sep [nest 2 (ppr before),
689 illegalBracket :: ThStage -> SDoc
691 = ptext (sLit "Illegal bracket at level") <+> ppr level
693 illegalSplice :: ThStage -> SDoc
695 = ptext (sLit "Illegal splice at level") <+> ppr level
701 %************************************************************************
705 %************************************************************************
709 reify :: TH.Name -> TcM TH.Info
711 = do { name <- lookupThName th_name
712 ; thing <- tcLookupTh name
713 -- ToDo: this tcLookup could fail, which would give a
714 -- rather unhelpful error message
715 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
719 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
720 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
721 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
722 ppr_ns _ = panic "reify/ppr_ns"
724 lookupThName :: TH.Name -> TcM Name
725 lookupThName th_name@(TH.Name occ flavour)
726 = do { mb_ns <- mapM lookup [ thRdrName gns occ_str flavour
727 | gns <- guessed_nss]
728 ; case catMaybes mb_ns of
729 [] -> failWithTc (notInScope th_name)
730 (n:_) -> return n } -- Pick the first that works
731 -- E.g. reify (mkName "A") will pick the class A
732 -- in preference to the data constructor A
735 = do { -- Repeat much of lookupOccRn, becase we want
736 -- to report errors in a TH-relevant way
737 ; rdr_env <- getLocalRdrEnv
738 ; case lookupLocalRdrEnv rdr_env rdr_name of
739 Just name -> return (Just name)
740 Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
741 -> do { name <- lookupImportedName rdr_name
742 ; return (Just name) }
743 | otherwise -- Unqual, Qual
744 -> lookupSrcOcc_maybe rdr_name }
746 -- guessed_ns are the name spaces guessed from looking at the TH name
747 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
748 | otherwise = [OccName.varName, OccName.tvName]
749 occ_str = TH.occString occ
751 tcLookupTh :: Name -> TcM TcTyThing
752 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
753 -- it gives a reify-related error message on failure, whereas in the normal
754 -- tcLookup, failure is a bug.
756 = do { (gbl_env, lcl_env) <- getEnvs
757 ; case lookupNameEnv (tcl_env lcl_env) name of {
758 Just thing -> return thing;
760 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
761 then -- It's defined in this module
762 case lookupNameEnv (tcg_type_env gbl_env) name of
763 Just thing -> return (AGlobal thing)
764 Nothing -> failWithTc (notInEnv name)
766 else do -- It's imported
767 { (eps,hpt) <- getEpsAndHpt
769 ; case lookupType dflags hpt (eps_PTE eps) name of
770 Just thing -> return (AGlobal thing)
771 Nothing -> do { thing <- tcImportDecl name
772 ; return (AGlobal thing) }
773 -- Imported names should always be findable;
774 -- if not, we fail hard in tcImportDecl
777 notInScope :: TH.Name -> SDoc
778 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
779 ptext (sLit "is not in scope at a reify")
780 -- Ugh! Rather an indirect way to display the name
782 notInEnv :: Name -> SDoc
783 notInEnv name = quotes (ppr name) <+>
784 ptext (sLit "is not in the type environment at a reify")
786 ------------------------------
787 reifyThing :: TcTyThing -> TcM TH.Info
788 -- The only reason this is monadic is for error reporting,
789 -- which in turn is mainly for the case when TH can't express
790 -- some random GHC extension
792 reifyThing (AGlobal (AnId id))
793 = do { ty <- reifyType (idType id)
794 ; fix <- reifyFixity (idName id)
795 ; let v = reifyName id
796 ; case globalIdDetails id of
797 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
798 _ -> return (TH.VarI v ty Nothing fix)
801 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
802 reifyThing (AGlobal (AClass cls)) = reifyClass cls
803 reifyThing (AGlobal (ADataCon dc))
804 = do { let name = dataConName dc
805 ; ty <- reifyType (idType (dataConWrapId dc))
806 ; fix <- reifyFixity name
807 ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
809 reifyThing (ATcId {tct_id = id, tct_type = ty})
810 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
811 -- though it may be incomplete
812 ; ty2 <- reifyType ty1
813 ; fix <- reifyFixity (idName id)
814 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
816 reifyThing (ATyVar tv ty)
817 = do { ty1 <- zonkTcType ty
818 ; ty2 <- reifyType ty1
819 ; return (TH.TyVarI (reifyName tv) ty2) }
821 reifyThing (AThing {}) = panic "reifyThing AThing"
823 ------------------------------
824 reifyTyCon :: TyCon -> TcM TH.Info
826 | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
827 | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
829 = do { let (tvs, rhs) = synTyConDefn tc
830 ; rhs' <- reifyType rhs
831 ; return (TH.TyConI $
832 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
835 = do { cxt <- reifyCxt (tyConStupidTheta tc)
836 ; let tvs = tyConTyVars tc
837 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
838 ; let name = reifyName tc
839 r_tvs = reifyTyVars tvs
840 deriv = [] -- Don't know about deriving
841 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
842 | otherwise = TH.DataD cxt name r_tvs cons deriv
843 ; return (TH.TyConI decl) }
845 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
847 | isVanillaDataCon dc
848 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
849 ; let stricts = map reifyStrict (dataConStrictMarks dc)
850 fields = dataConFieldLabels dc
854 ; ASSERT( length arg_tys == length stricts )
855 if not (null fields) then
856 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
858 if dataConIsInfix dc then
859 ASSERT( length arg_tys == 2 )
860 return (TH.InfixC (s1,a1) name (s2,a2))
862 return (TH.NormalC name (stricts `zip` arg_tys)) }
864 = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:")
867 ------------------------------
868 reifyClass :: Class -> TcM TH.Info
870 = do { cxt <- reifyCxt theta
871 ; ops <- mapM reify_op op_stuff
872 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
874 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
875 fds' = map reifyFunDep fds
876 reify_op (op, _) = do { ty <- reifyType (idType op)
877 ; return (TH.SigD (reifyName op) ty) }
879 ------------------------------
880 reifyType :: TypeRep.Type -> TcM TH.Type
881 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
882 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
883 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
884 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
885 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
886 ; tau' <- reifyType tau
887 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
889 (tvs, cxt, tau) = tcSplitSigmaTy ty
890 reifyType (PredTy {}) = panic "reifyType PredTy"
892 reifyTypes :: [Type] -> TcM [TH.Type]
893 reifyTypes = mapM reifyType
894 reifyCxt :: [PredType] -> TcM [TH.Type]
895 reifyCxt = mapM reifyPred
897 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
898 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
900 reifyTyVars :: [TyVar] -> [TH.Name]
901 reifyTyVars = map reifyName
903 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
904 reify_tc_app tc tys = do { tys' <- reifyTypes tys
905 ; return (foldl TH.AppT (TH.ConT tc) tys') }
907 reifyPred :: TypeRep.PredType -> TcM TH.Type
908 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
909 reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
910 reifyPred (EqPred {}) = panic "reifyPred EqPred"
913 ------------------------------
914 reifyName :: NamedThing n => n -> TH.Name
916 | isExternalName name = mk_varg pkg_str mod_str occ_str
917 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
918 -- Many of the things we reify have local bindings, and
919 -- NameL's aren't supposed to appear in binding positions, so
920 -- we use NameU. When/if we start to reify nested things, that
921 -- have free variables, we may need to generate NameL's for them.
924 mod = ASSERT( isExternalName name ) nameModule name
925 pkg_str = packageIdString (modulePackageId mod)
926 mod_str = moduleNameString (moduleName mod)
927 occ_str = occNameString occ
928 occ = nameOccName name
929 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
930 | OccName.isVarOcc occ = TH.mkNameG_v
931 | OccName.isTcOcc occ = TH.mkNameG_tc
932 | otherwise = pprPanic "reifyName" (ppr name)
934 ------------------------------
935 reifyFixity :: Name -> TcM TH.Fixity
937 = do { fix <- lookupFixityRn name
938 ; return (conv_fix fix) }
940 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
941 conv_dir BasicTypes.InfixR = TH.InfixR
942 conv_dir BasicTypes.InfixL = TH.InfixL
943 conv_dir BasicTypes.InfixN = TH.InfixN
945 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
946 reifyStrict MarkedStrict = TH.IsStrict
947 reifyStrict MarkedUnboxed = TH.IsStrict
948 reifyStrict NotMarkedStrict = TH.NotStrict
950 ------------------------------
951 noTH :: LitString -> SDoc -> TcM a
952 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
953 ptext (sLit "in Template Haskell:"),