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)
67 import qualified Language.Haskell.TH as TH
68 -- THSyntax gives access to internal functions and data types
69 import qualified Language.Haskell.TH.Syntax as TH
71 import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
72 import qualified Control.Exception as Exception( userErrors )
75 Note [Template Haskell levels]
76 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
77 * Imported things are impLevel (= 0)
79 * In GHCi, variables bound by a previous command are treated
80 as impLevel, because we have bytecode for them.
82 * Variables are bound at the "current level"
84 * The current level starts off at topLevel (= 1)
86 * The level is decremented by splicing $(..)
87 incremented by brackets [| |]
88 incremented by name-quoting 'f
90 When a variable is used, we compare
91 bind: binding level, and
92 use: current level at usage site
95 bind > use Always error (bound later than used)
98 bind = use Always OK (bound same stage as used)
99 [| \x -> $(f [| x |]) |]
101 bind < use Inside brackets, it depends
105 For (bind < use) inside brackets, there are three cases:
106 - Imported things OK f = [| map |]
107 - Top-level things OK g = [| f |]
108 - Non-top-level Only if there is a liftable instance
109 h = \(x:Int) -> [| x |]
111 See Note [What is a top-level Id?]
115 A quoted name 'n is a bit like a quoted expression [| n |], except that we
116 have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
117 the use-level to account for the brackets, the cases are:
126 See Note [What is a top-level Id?] in TcEnv. Examples:
128 f 'map -- OK; also for top-level defns of this module
130 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
131 -- cross-stage lifting
133 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
135 [| \x. $(f 'x) |] -- OK
138 Note [What is a top-level Id?]
139 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
140 In the level-control criteria above, we need to know what a "top level Id" is.
141 There are three kinds:
142 * Imported from another module (GlobalId, ExternalName)
143 * Bound at the top level of this module (ExternalName)
144 * In GHCi, bound by a previous stmt (GlobalId)
145 It's strange that there is no one criterion tht picks out all three, but that's
146 how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids
147 bound in an earlier Stmt, but what module would you choose? See
148 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
150 The predicate we use is TcEnv.thTopLevelId.
153 %************************************************************************
155 \subsection{Main interface + stubs for the non-GHCI case
157 %************************************************************************
160 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
161 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
162 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
163 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
164 -- None of these functions add constraints to the LIE
166 runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
167 runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
170 tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
171 tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
172 tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
173 kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
175 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
176 runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
180 %************************************************************************
182 \subsection{Quoting an expression}
184 %************************************************************************
186 Note [Handling brackets]
187 ~~~~~~~~~~~~~~~~~~~~~~~~
188 Source: f = [| Just $(g 3) |]
189 The [| |] part is a HsBracket
191 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
192 The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
193 The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
195 Desugared: f = do { s7 <- g Int 3
196 ; return (ConE "Data.Maybe.Just" s7) }
199 tcBracket brack res_ty = do
201 case bracketOK level of {
202 Nothing -> failWithTc (illegalBracket level) ;
203 Just next_level -> do
205 -- Typecheck expr to make sure it is valid,
206 -- but throw away the results. We'll type check
207 -- it again when we actually use it.
209 pending_splices <- newMutVar []
212 (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
213 (getLIE (tc_bracket next_level brack))
214 tcSimplifyBracket lie
216 -- Make the expected type have the right shape
217 boxyUnify meta_ty res_ty
219 -- Return the original expression, not the type-decorated one
220 pendings <- readMutVar pending_splices
221 return (noLoc (HsBracketOut brack pendings))
224 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
225 tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
226 = do { thing <- tcLookup name
228 AGlobal _ -> return ()
229 ATcId { tct_level = bind_lvl, tct_id = id }
230 | thTopLevelId id -- C.f thTopLevelId case of
231 -> keepAliveTc id -- TcExpr.thBrackId
233 -> do { checkTc (use_lvl == bind_lvl)
234 (quotedNameStageErr name) }
235 _ -> pprPanic "th_bracket" (ppr name)
237 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
240 tc_bracket _ (ExpBr expr)
241 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
242 ; tcMonoExpr expr any_ty
243 ; tcMetaTy expQTyConName }
244 -- Result type is Expr (= Q Exp)
246 tc_bracket _ (TypBr typ)
247 = do { tcHsSigType ExprSigCtxt typ
248 ; tcMetaTy typeQTyConName }
249 -- Result type is Type (= Q Typ)
251 tc_bracket _ (DecBr decls)
252 = do { tcTopSrcDecls emptyModDetails decls
253 -- Typecheck the declarations, dicarding the result
254 -- We'll get all that stuff later, when we splice it in
256 ; decl_ty <- tcMetaTy decTyConName
257 ; q_ty <- tcMetaTy qTyConName
258 ; return (mkAppTy q_ty (mkListTy decl_ty))
259 -- Result type is Q [Dec]
262 tc_bracket _ (PatBr _)
263 = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
265 quotedNameStageErr :: Name -> SDoc
267 = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
268 , ptext (sLit "must be used at the same stage at which is is bound")]
272 %************************************************************************
274 \subsection{Splicing an expression}
276 %************************************************************************
279 tcSpliceExpr (HsSplice name expr) res_ty
280 = setSrcSpan (getLoc expr) $ do
282 case spliceOK level of {
283 Nothing -> failWithTc (illegalSplice level) ;
287 Comp -> do { e <- tcTopSplice expr res_ty
288 ; return (unLoc e) } ;
289 Brack _ ps_var lie_var -> do
291 -- A splice inside brackets
292 -- NB: ignore res_ty, apart from zapping it to a mono-type
293 -- e.g. [| reverse $(h 4) |]
294 -- Here (h 4) :: Q Exp
295 -- but $(h 4) :: forall a.a i.e. anything!
298 meta_exp_ty <- tcMetaTy expQTyConName
299 expr' <- setStage (Splice next_level) (
301 tcMonoExpr expr meta_exp_ty
304 -- Write the pending splice into the bucket
305 ps <- readMutVar ps_var
306 writeMutVar ps_var ((name,expr') : ps)
308 return (panic "tcSpliceExpr") -- The returned expression is ignored
310 ; Splice {} -> panic "tcSpliceExpr Splice"
313 -- tcTopSplice used to have this:
314 -- Note that we do not decrement the level (to -1) before
315 -- typechecking the expression. For example:
316 -- f x = $( ...$(g 3) ... )
317 -- The recursive call to tcMonoExpr will simply expand the
318 -- inner escape before dealing with the outer one
320 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
321 tcTopSplice expr res_ty = do
322 meta_exp_ty <- tcMetaTy expQTyConName
324 -- Typecheck the expression
325 zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
327 -- Run the expression
328 traceTc (text "About to run" <+> ppr zonked_q_expr)
329 expr2 <- runMetaE convertToHsExpr zonked_q_expr
331 traceTc (text "Got result" <+> ppr expr2)
333 showSplice "expression"
334 zonked_q_expr (ppr expr2)
336 -- Rename it, but bale out if there are errors
337 -- otherwise the type checker just gives more spurious errors
338 (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
340 tcMonoExpr exp3 res_ty
343 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
344 -- Type check an expression that is the body of a top-level splice
345 -- (the caller will compile and run it)
346 tcTopSpliceExpr expr meta_ty
347 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
348 -- if the type checker fails!
350 setStage topSpliceStage $ do
353 do { recordThUse -- Record that TH is used (for pkg depdendency)
355 -- Typecheck the expression
356 ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
358 -- Solve the constraints
359 ; const_binds <- tcSimplifyTop lie
362 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
366 %************************************************************************
370 %************************************************************************
372 Note [Quasi-quote overview]
373 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
374 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
375 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
380 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
381 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
382 defined in another module, because we are going to run it here. It's
383 a bit like a TH splice:
386 However, you can do this in patterns as well as terms. Becuase of this,
387 the splice is run by the *renamer* rather than the type checker.
390 runQuasiQuote :: Outputable hs_syn
391 => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
392 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
393 -> String -- Documentation string only
394 -> Name -- Name of th_syn type
395 -> (SrcSpan -> th_syn -> Either Message hs_syn)
397 runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
398 = do { -- Check that the quoter is not locally defined, otherwise the TH
399 -- machinery will not be able to run the quasiquote.
400 ; this_mod <- getModule
401 ; let is_local = case nameModule_maybe quoter of
402 Just mod | mod == this_mod -> True
405 ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
406 ; checkTc (not is_local) (quoteStageError quoter)
408 -- Build the expression
409 ; let quoterExpr = L q_span $! HsVar $! quoter
410 ; let quoteExpr = L q_span $! HsLit $! HsString quote
411 ; let expr = L q_span $
413 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
415 ; meta_exp_ty <- tcMetaTy meta_ty
417 -- Typecheck the expression
418 ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
420 -- Run the expression
421 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
422 ; result <- runMeta convert zonked_q_expr
423 ; traceTc (text "Got result" <+> ppr result)
424 ; showSplice desc zonked_q_expr (ppr result)
428 runQuasiQuoteExpr quasiquote
429 = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
431 runQuasiQuotePat quasiquote
432 = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
434 quoteStageError :: Name -> SDoc
435 quoteStageError quoter
436 = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
437 nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
441 %************************************************************************
445 %************************************************************************
447 Very like splicing an expression, but we don't yet share code.
450 kcSpliceType (HsSplice name hs_expr)
451 = setSrcSpan (getLoc hs_expr) $ do
453 ; case spliceOK level of {
454 Nothing -> failWithTc (illegalSplice level) ;
455 Just next_level -> do
458 Comp -> do { (t,k) <- kcTopSpliceType hs_expr
459 ; return (unLoc t, k) } ;
460 Brack _ ps_var lie_var -> do
462 { -- A splice inside brackets
463 ; meta_ty <- tcMetaTy typeQTyConName
464 ; expr' <- setStage (Splice next_level) $
466 tcMonoExpr hs_expr meta_ty
468 -- Write the pending splice into the bucket
469 ; ps <- readMutVar ps_var
470 ; writeMutVar ps_var ((name,expr') : ps)
472 -- e.g. [| Int -> $(h 4) |]
473 -- Here (h 4) :: Q Type
474 -- but $(h 4) :: forall a.a i.e. any kind
476 ; return (panic "kcSpliceType", kind) -- The returned type is ignored
478 ; Splice {} -> panic "kcSpliceType Splice"
481 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
483 = do { meta_ty <- tcMetaTy typeQTyConName
485 -- Typecheck the expression
486 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
488 -- Run the expression
489 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
490 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
492 ; traceTc (text "Got result" <+> ppr hs_ty2)
494 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
496 -- Rename it, but bale out if there are errors
497 -- otherwise the type checker just gives more spurious errors
498 ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
499 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
504 %************************************************************************
506 \subsection{Splicing an expression}
508 %************************************************************************
511 -- Always at top level
512 -- Type sig at top of file:
513 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
515 = do { meta_dec_ty <- tcMetaTy decTyConName
516 ; meta_q_ty <- tcMetaTy qTyConName
517 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
518 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
520 -- Run the expression
521 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
522 ; decls <- runMetaD convertToHsDecls zonked_q_expr
524 ; traceTc (text "Got result" <+> vcat (map ppr decls))
525 ; showSplice "declarations"
527 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
532 %************************************************************************
534 \subsection{Running an expression}
536 %************************************************************************
539 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
540 -> LHsExpr Id -- Of type (Q Exp)
541 -> TcM (LHsExpr RdrName)
544 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
545 -> LHsExpr Id -- Of type (Q Pat)
549 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
550 -> LHsExpr Id -- Of type (Q Type)
551 -> TcM (LHsType RdrName)
554 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
555 -> LHsExpr Id -- Of type Q [Dec]
556 -> TcM [LHsDecl RdrName]
559 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
560 -> LHsExpr Id -- Of type X
561 -> TcM hs_syn -- Of type t
564 ds_expr <- initDsTc (dsLExpr expr)
565 -- Compile and link it; might fail if linking fails
566 ; hsc_env <- getTopEnv
567 ; src_span <- getSrcSpanM
568 ; either_hval <- tryM $ liftIO $
569 HscMain.compileExpr hsc_env src_span ds_expr
570 ; case either_hval of {
571 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
574 { -- Coerce it to Q t, and run it
576 -- Running might fail if it throws an exception of any kind (hence tryAllM)
577 -- including, say, a pattern-match exception in the code we are running
579 -- We also do the TH -> HS syntax conversion inside the same
580 -- exception-cacthing thing so that if there are any lurking
581 -- exceptions in the data structure returned by hval, we'll
582 -- encounter them inside the try
584 -- See Note [Exceptions in TH]
585 let expr_span = getLoc expr
586 ; either_tval <- tryAllM $
587 setSrcSpan expr_span $ -- Set the span so that qLocation can
588 -- see where this splice is
589 do { th_syn <- TH.runQ (unsafeCoerce# hval)
590 ; case convert expr_span th_syn of
591 Left err -> failWithTc err
592 Right hs_syn -> return hs_syn }
594 ; case either_tval of
596 Left exn | Just s <- Exception.userErrors exn
597 , s == "IOEnv failure"
598 -> failM -- Error already in Tc monad
599 | otherwise -> failWithTc (mk_msg "run" exn) -- Exception
602 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
603 nest 2 (text (Panic.showException exn)),
604 nest 2 (text "Code:" <+> ppr expr)]
607 Note [Exceptions in TH]
608 ~~~~~~~~~~~~~~~~~~~~~~~
609 Supppose we have something like this
613 f n | n>3 = fail "Too many declarations"
616 The 'fail' is a user-generated failure, and should be displayed as a
617 perfectly ordinary compiler error message, not a panic or anything
618 like that. Here's how it's processed:
620 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
621 effectively transforms (fail s) to
622 qReport True s >> fail
623 where 'qReport' comes from the Quasi class and fail from its monad
626 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
627 (qReport True s) by using addErr to add an error message to the bag of errors.
628 The 'fail' in TcM raises a UserError, with the uninteresting string
631 * So, when running a splice, we catch all exceptions; then for
632 - a UserError "IOEnv failure", we assume the error is already
633 in the error-bag (above)
634 - other errors, we add an error to the bag
638 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
641 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
642 qNewName s = do { u <- newUnique
644 ; return (TH.mkNameU s i) }
646 qReport True msg = addErr (text msg)
647 qReport False msg = addReport (text msg)
649 qLocation = do { m <- getModule
651 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
652 , TH.loc_module = moduleNameString (moduleName m)
653 , TH.loc_package = packageIdString (modulePackageId m)
654 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
655 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
659 -- For qRecover, discard error messages if
660 -- the recovery action is chosen. Otherwise
661 -- we'll only fail higher up. c.f. tryTcLIE_
662 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
664 Just val -> do { addMessages msgs -- There might be warnings
666 Nothing -> recover -- Discard all msgs
669 qRunIO io = liftIO io
673 %************************************************************************
675 \subsection{Errors and contexts}
677 %************************************************************************
680 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
681 showSplice what before after = do
683 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
684 nest 2 (sep [nest 2 (ppr before),
688 illegalBracket :: ThStage -> SDoc
690 = ptext (sLit "Illegal bracket at level") <+> ppr level
692 illegalSplice :: ThStage -> SDoc
694 = ptext (sLit "Illegal splice at level") <+> ppr level
700 %************************************************************************
704 %************************************************************************
708 reify :: TH.Name -> TcM TH.Info
710 = do { name <- lookupThName th_name
711 ; thing <- tcLookupTh name
712 -- ToDo: this tcLookup could fail, which would give a
713 -- rather unhelpful error message
714 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
718 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
719 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
720 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
721 ppr_ns _ = panic "reify/ppr_ns"
723 lookupThName :: TH.Name -> TcM Name
724 lookupThName th_name@(TH.Name occ flavour)
725 = do { mb_ns <- mapM lookup [ thRdrName gns occ_str flavour
726 | gns <- guessed_nss]
727 ; case catMaybes mb_ns of
728 [] -> failWithTc (notInScope th_name)
729 (n:_) -> return n } -- Pick the first that works
730 -- E.g. reify (mkName "A") will pick the class A
731 -- in preference to the data constructor A
734 = do { -- Repeat much of lookupOccRn, becase we want
735 -- to report errors in a TH-relevant way
736 ; rdr_env <- getLocalRdrEnv
737 ; case lookupLocalRdrEnv rdr_env rdr_name of
738 Just name -> return (Just name)
739 Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
740 -> do { name <- lookupImportedName rdr_name
741 ; return (Just name) }
742 | otherwise -- Unqual, Qual
743 -> lookupSrcOcc_maybe rdr_name }
745 -- guessed_ns are the name spaces guessed from looking at the TH name
746 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
747 | otherwise = [OccName.varName, OccName.tvName]
748 occ_str = TH.occString occ
750 tcLookupTh :: Name -> TcM TcTyThing
751 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
752 -- it gives a reify-related error message on failure, whereas in the normal
753 -- tcLookup, failure is a bug.
755 = do { (gbl_env, lcl_env) <- getEnvs
756 ; case lookupNameEnv (tcl_env lcl_env) name of {
757 Just thing -> return thing;
759 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
760 then -- It's defined in this module
761 case lookupNameEnv (tcg_type_env gbl_env) name of
762 Just thing -> return (AGlobal thing)
763 Nothing -> failWithTc (notInEnv name)
765 else do -- It's imported
766 { (eps,hpt) <- getEpsAndHpt
768 ; case lookupType dflags hpt (eps_PTE eps) name of
769 Just thing -> return (AGlobal thing)
770 Nothing -> do { thing <- tcImportDecl name
771 ; return (AGlobal thing) }
772 -- Imported names should always be findable;
773 -- if not, we fail hard in tcImportDecl
776 notInScope :: TH.Name -> SDoc
777 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
778 ptext (sLit "is not in scope at a reify")
779 -- Ugh! Rather an indirect way to display the name
781 notInEnv :: Name -> SDoc
782 notInEnv name = quotes (ppr name) <+>
783 ptext (sLit "is not in the type environment at a reify")
785 ------------------------------
786 reifyThing :: TcTyThing -> TcM TH.Info
787 -- The only reason this is monadic is for error reporting,
788 -- which in turn is mainly for the case when TH can't express
789 -- some random GHC extension
791 reifyThing (AGlobal (AnId id))
792 = do { ty <- reifyType (idType id)
793 ; fix <- reifyFixity (idName id)
794 ; let v = reifyName id
795 ; case globalIdDetails id of
796 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
797 _ -> return (TH.VarI v ty Nothing fix)
800 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
801 reifyThing (AGlobal (AClass cls)) = reifyClass cls
802 reifyThing (AGlobal (ADataCon dc))
803 = do { let name = dataConName dc
804 ; ty <- reifyType (idType (dataConWrapId dc))
805 ; fix <- reifyFixity name
806 ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
808 reifyThing (ATcId {tct_id = id, tct_type = ty})
809 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
810 -- though it may be incomplete
811 ; ty2 <- reifyType ty1
812 ; fix <- reifyFixity (idName id)
813 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
815 reifyThing (ATyVar tv ty)
816 = do { ty1 <- zonkTcType ty
817 ; ty2 <- reifyType ty1
818 ; return (TH.TyVarI (reifyName tv) ty2) }
820 reifyThing (AThing {}) = panic "reifyThing AThing"
822 ------------------------------
823 reifyTyCon :: TyCon -> TcM TH.Info
825 | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
826 | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
828 = do { let (tvs, rhs) = synTyConDefn tc
829 ; rhs' <- reifyType rhs
830 ; return (TH.TyConI $
831 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
834 = do { cxt <- reifyCxt (tyConStupidTheta tc)
835 ; let tvs = tyConTyVars tc
836 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
837 ; let name = reifyName tc
838 r_tvs = reifyTyVars tvs
839 deriv = [] -- Don't know about deriving
840 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
841 | otherwise = TH.DataD cxt name r_tvs cons deriv
842 ; return (TH.TyConI decl) }
844 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
846 | isVanillaDataCon dc
847 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
848 ; let stricts = map reifyStrict (dataConStrictMarks dc)
849 fields = dataConFieldLabels dc
853 ; ASSERT( length arg_tys == length stricts )
854 if not (null fields) then
855 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
857 if dataConIsInfix dc then
858 ASSERT( length arg_tys == 2 )
859 return (TH.InfixC (s1,a1) name (s2,a2))
861 return (TH.NormalC name (stricts `zip` arg_tys)) }
863 = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:")
866 ------------------------------
867 reifyClass :: Class -> TcM TH.Info
869 = do { cxt <- reifyCxt theta
870 ; ops <- mapM reify_op op_stuff
871 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
873 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
874 fds' = map reifyFunDep fds
875 reify_op (op, _) = do { ty <- reifyType (idType op)
876 ; return (TH.SigD (reifyName op) ty) }
878 ------------------------------
879 reifyType :: TypeRep.Type -> TcM TH.Type
880 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
881 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
882 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
883 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
884 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
885 ; tau' <- reifyType tau
886 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
888 (tvs, cxt, tau) = tcSplitSigmaTy ty
889 reifyType (PredTy {}) = panic "reifyType PredTy"
891 reifyTypes :: [Type] -> TcM [TH.Type]
892 reifyTypes = mapM reifyType
893 reifyCxt :: [PredType] -> TcM [TH.Type]
894 reifyCxt = mapM reifyPred
896 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
897 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
899 reifyTyVars :: [TyVar] -> [TH.Name]
900 reifyTyVars = map reifyName
902 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
903 reify_tc_app tc tys = do { tys' <- reifyTypes tys
904 ; return (foldl TH.AppT (TH.ConT tc) tys') }
906 reifyPred :: TypeRep.PredType -> TcM TH.Type
907 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
908 reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
909 reifyPred (EqPred {}) = panic "reifyPred EqPred"
912 ------------------------------
913 reifyName :: NamedThing n => n -> TH.Name
915 | isExternalName name = mk_varg pkg_str mod_str occ_str
916 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
917 -- Many of the things we reify have local bindings, and
918 -- NameL's aren't supposed to appear in binding positions, so
919 -- we use NameU. When/if we start to reify nested things, that
920 -- have free variables, we may need to generate NameL's for them.
923 mod = nameModule name
924 pkg_str = packageIdString (modulePackageId mod)
925 mod_str = moduleNameString (moduleName mod)
926 occ_str = occNameString occ
927 occ = nameOccName name
928 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
929 | OccName.isVarOcc occ = TH.mkNameG_v
930 | OccName.isTcOcc occ = TH.mkNameG_tc
931 | otherwise = pprPanic "reifyName" (ppr name)
933 ------------------------------
934 reifyFixity :: Name -> TcM TH.Fixity
936 = do { fix <- lookupFixityRn name
937 ; return (conv_fix fix) }
939 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
940 conv_dir BasicTypes.InfixR = TH.InfixR
941 conv_dir BasicTypes.InfixL = TH.InfixL
942 conv_dir BasicTypes.InfixN = TH.InfixN
944 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
945 reifyStrict MarkedStrict = TH.IsStrict
946 reifyStrict MarkedUnboxed = TH.IsStrict
947 reifyStrict NotMarkedStrict = TH.NotStrict
949 ------------------------------
950 noTH :: LitString -> SDoc -> TcM a
951 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
952 ptext (sLit "in Template Haskell:"),