2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcSplice: Template Haskell splices
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
58 import DsMonad hiding (Splice)
70 import qualified Language.Haskell.TH as TH
71 -- THSyntax gives access to internal functions and data types
72 import qualified Language.Haskell.TH.Syntax as TH
74 import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
75 import Control.Monad ( liftM )
76 import qualified Control.Exception as Exception( userErrors )
79 Note [Template Haskell levels]
80 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
81 * Imported things are impLevel (= 0)
83 * In GHCi, variables bound by a previous command are treated
84 as impLevel, because we have bytecode for them.
86 * Variables are bound at the "current level"
88 * The current level starts off at topLevel (= 1)
90 * The level is decremented by splicing $(..)
91 incremented by brackets [| |]
92 incremented by name-quoting 'f
94 When a variable is used, we compare
95 bind: binding level, and
96 use: current level at usage site
99 bind > use Always error (bound later than used)
102 bind = use Always OK (bound same stage as used)
103 [| \x -> $(f [| x |]) |]
105 bind < use Inside brackets, it depends
109 For (bind < use) inside brackets, there are three cases:
110 - Imported things OK f = [| map |]
111 - Top-level things OK g = [| f |]
112 - Non-top-level Only if there is a liftable instance
113 h = \(x:Int) -> [| x |]
115 See Note [What is a top-level Id?]
119 A quoted name 'n is a bit like a quoted expression [| n |], except that we
120 have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
121 the use-level to account for the brackets, the cases are:
130 See Note [What is a top-level Id?] in TcEnv. Examples:
132 f 'map -- OK; also for top-level defns of this module
134 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
135 -- cross-stage lifting
137 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
139 [| \x. $(f 'x) |] -- OK
142 Note [What is a top-level Id?]
143 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
144 In the level-control criteria above, we need to know what a "top level Id" is.
145 There are three kinds:
146 * Imported from another module (GlobalId, ExternalName)
147 * Bound at the top level of this module (ExternalName)
148 * In GHCi, bound by a previous stmt (GlobalId)
149 It's strange that there is no one criterion tht picks out all three, but that's
150 how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids
151 bound in an earlier Stmt, but what module would you choose? See
152 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
154 The predicate we use is TcEnv.thTopLevelId.
157 %************************************************************************
159 \subsection{Main interface + stubs for the non-GHCI case
161 %************************************************************************
164 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
165 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
166 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
167 -- None of these functions add constraints to the LIE
169 runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
170 runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
173 tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
174 tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
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 :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
201 tcBracket brack res_ty = do
203 case bracketOK level of {
204 Nothing -> failWithTc (illegalBracket level) ;
205 Just next_level -> do
207 -- Typecheck expr to make sure it is valid,
208 -- but throw away the results. We'll type check
209 -- it again when we actually use it.
211 pending_splices <- newMutVar []
214 (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
215 (getLIE (tc_bracket next_level brack))
216 tcSimplifyBracket lie
218 -- Make the expected type have the right shape
219 boxyUnify meta_ty res_ty
221 -- Return the original expression, not the type-decorated one
222 pendings <- readMutVar pending_splices
223 return (noLoc (HsBracketOut brack pendings))
226 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
227 tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
228 = do { thing <- tcLookup name
230 AGlobal _ -> return ()
231 ATcId { tct_level = bind_lvl, tct_id = id }
232 | thTopLevelId id -- C.f thTopLevelId case of
233 -> keepAliveTc id -- TcExpr.thBrackId
235 -> do { checkTc (use_lvl == bind_lvl)
236 (quotedNameStageErr name) }
237 other -> pprPanic "th_bracket" (ppr name)
239 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
242 tc_bracket use_lvl (ExpBr expr)
243 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
244 ; tcMonoExpr expr any_ty
245 ; tcMetaTy expQTyConName }
246 -- Result type is Expr (= Q Exp)
248 tc_bracket use_lvl (TypBr typ)
249 = do { tcHsSigType ExprSigCtxt typ
250 ; tcMetaTy typeQTyConName }
251 -- Result type is Type (= Q Typ)
253 tc_bracket use_lvl (DecBr decls)
254 = do { tcTopSrcDecls emptyModDetails decls
255 -- Typecheck the declarations, dicarding the result
256 -- We'll get all that stuff later, when we splice it in
258 ; decl_ty <- tcMetaTy decTyConName
259 ; q_ty <- tcMetaTy qTyConName
260 ; return (mkAppTy q_ty (mkListTy decl_ty))
261 -- Result type is Q [Dec]
264 tc_bracket use_lvl (PatBr _)
265 = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet"))
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
312 -- tcTopSplice used to have this:
313 -- Note that we do not decrement the level (to -1) before
314 -- typechecking the expression. For example:
315 -- f x = $( ...$(g 3) ... )
316 -- The recursive call to tcMonoExpr will simply expand the
317 -- inner escape before dealing with the outer one
319 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
320 tcTopSplice expr res_ty = do
321 meta_exp_ty <- tcMetaTy expQTyConName
323 -- Typecheck the expression
324 zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
326 -- Run the expression
327 traceTc (text "About to run" <+> ppr zonked_q_expr)
328 expr2 <- runMetaE convertToHsExpr zonked_q_expr
330 traceTc (text "Got result" <+> ppr expr2)
332 showSplice "expression"
333 zonked_q_expr (ppr expr2)
335 -- Rename it, but bale out if there are errors
336 -- otherwise the type checker just gives more spurious errors
337 (exp3, fvs) <- checkNoErrs (rnLExpr expr2)
339 tcMonoExpr exp3 res_ty
342 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
343 -- Type check an expression that is the body of a top-level splice
344 -- (the caller will compile and run it)
345 tcTopSpliceExpr expr meta_ty
346 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
347 -- if the type checker fails!
349 setStage topSpliceStage $ do
352 do { recordThUse -- Record that TH is used (for pkg depdendency)
354 -- Typecheck the expression
355 ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
357 -- Solve the constraints
358 ; const_binds <- tcSimplifyTop lie
361 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
365 %************************************************************************
369 %************************************************************************
371 Note [Quasi-quote overview]
372 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
373 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
374 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
379 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
380 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
381 defined in another module, because we are going to run it here. It's
382 a bit like a TH splice:
385 However, you can do this in patterns as well as terms. Becuase of this,
386 the splice is run by the *renamer* rather than the type checker.
389 runQuasiQuote :: Outputable hs_syn
390 => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
391 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
392 -> String -- Documentation string only
393 -> Name -- Name of th_syn type
394 -> (SrcSpan -> th_syn -> Either Message hs_syn)
396 runQuasiQuote (HsQuasiQuote name quoter q_span quote) quote_selector desc meta_ty convert
397 = do { -- Check that the quoter is not locally defined, otherwise the TH
398 -- machinery will not be able to run the quasiquote.
399 ; this_mod <- getModule
400 ; let is_local = case nameModule_maybe quoter of
401 Just mod | mod == this_mod -> True
404 ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
405 ; checkTc (not is_local) (quoteStageError quoter)
407 -- Build the expression
408 ; let quoterExpr = L q_span $! HsVar $! quoter
409 ; let quoteExpr = L q_span $! HsLit $! HsString quote
410 ; let expr = L q_span $
412 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
414 ; meta_exp_ty <- tcMetaTy meta_ty
416 -- Typecheck the expression
417 ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
419 -- Run the expression
420 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
421 ; result <- runMeta convert zonked_q_expr
422 ; traceTc (text "Got result" <+> ppr result)
423 ; showSplice desc zonked_q_expr (ppr result)
427 runQuasiQuoteExpr quasiquote
428 = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
430 runQuasiQuotePat quasiquote
431 = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
433 quoteStageError quoter
434 = sep [ptext SLIT("GHC stage restriction:") <+> ppr quoter,
435 nest 2 (ptext SLIT("is used in a quasiquote, and must be imported, not defined locally"))]
439 %************************************************************************
443 %************************************************************************
445 Very like splicing an expression, but we don't yet share code.
448 kcSpliceType (HsSplice name hs_expr)
449 = setSrcSpan (getLoc hs_expr) $ do
451 ; case spliceOK level of {
452 Nothing -> failWithTc (illegalSplice level) ;
453 Just next_level -> do
456 Comp -> do { (t,k) <- kcTopSpliceType hs_expr
457 ; return (unLoc t, k) } ;
458 Brack _ ps_var lie_var -> do
460 { -- A splice inside brackets
461 ; meta_ty <- tcMetaTy typeQTyConName
462 ; expr' <- setStage (Splice next_level) $
464 tcMonoExpr hs_expr meta_ty
466 -- Write the pending splice into the bucket
467 ; ps <- readMutVar ps_var
468 ; writeMutVar ps_var ((name,expr') : ps)
470 -- e.g. [| Int -> $(h 4) |]
471 -- Here (h 4) :: Q Type
472 -- but $(h 4) :: forall a.a i.e. any kind
474 ; return (panic "kcSpliceType", kind) -- The returned type is ignored
477 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
479 = do { meta_ty <- tcMetaTy typeQTyConName
481 -- Typecheck the expression
482 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
484 -- Run the expression
485 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
486 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
488 ; traceTc (text "Got result" <+> ppr hs_ty2)
490 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
492 -- Rename it, but bale out if there are errors
493 -- otherwise the type checker just gives more spurious errors
494 ; let doc = ptext SLIT("In the spliced type") <+> ppr hs_ty2
495 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
500 %************************************************************************
502 \subsection{Splicing an expression}
504 %************************************************************************
507 -- Always at top level
508 -- Type sig at top of file:
509 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
511 = do { meta_dec_ty <- tcMetaTy decTyConName
512 ; meta_q_ty <- tcMetaTy qTyConName
513 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
514 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
516 -- Run the expression
517 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
518 ; decls <- runMetaD convertToHsDecls zonked_q_expr
520 ; traceTc (text "Got result" <+> vcat (map ppr decls))
521 ; showSplice "declarations"
523 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
526 where handleErrors :: [Either a Message] -> TcM [a]
527 handleErrors [] = return []
528 handleErrors (Left x:xs) = liftM (x:) (handleErrors xs)
529 handleErrors (Right m:xs) = do addErrTc m
534 %************************************************************************
536 \subsection{Running an expression}
538 %************************************************************************
541 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
542 -> LHsExpr Id -- Of type (Q Exp)
543 -> TcM (LHsExpr RdrName)
546 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
547 -> LHsExpr Id -- Of type (Q Pat)
551 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
552 -> LHsExpr Id -- Of type (Q Type)
553 -> TcM (LHsType RdrName)
556 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
557 -> LHsExpr Id -- Of type Q [Dec]
558 -> TcM [LHsDecl RdrName]
561 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
562 -> LHsExpr Id -- Of type X
563 -> TcM hs_syn -- Of type t
566 ds_expr <- initDsTc (dsLExpr expr)
567 -- Compile and link it; might fail if linking fails
568 ; hsc_env <- getTopEnv
569 ; src_span <- getSrcSpanM
570 ; either_hval <- tryM $ liftIO $
571 HscMain.compileExpr hsc_env src_span ds_expr
572 ; case either_hval of {
573 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
576 { -- Coerce it to Q t, and run it
578 -- Running might fail if it throws an exception of any kind (hence tryAllM)
579 -- including, say, a pattern-match exception in the code we are running
581 -- We also do the TH -> HS syntax conversion inside the same
582 -- exception-cacthing thing so that if there are any lurking
583 -- exceptions in the data structure returned by hval, we'll
584 -- encounter them inside the try
586 -- See Note [Exceptions in TH]
587 let expr_span = getLoc expr
588 ; either_tval <- tryAllM $
589 setSrcSpan expr_span $ -- Set the span so that qLocation can
590 -- see where this splice is
591 do { th_syn <- TH.runQ (unsafeCoerce# hval)
592 ; case convert expr_span th_syn of
593 Left err -> failWithTc err
594 Right hs_syn -> return hs_syn }
596 ; case either_tval of
598 Left exn | Just s <- Exception.userErrors exn
599 , s == "IOEnv failure"
600 -> failM -- Error already in Tc monad
601 | otherwise -> failWithTc (mk_msg "run" exn) -- 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 a UserError, with the uninteresting string
633 * So, when running a splice, we catch all exceptions; then for
634 - a UserError "IOEnv failure", we assume the error is already
635 in the error-bag (above)
636 - other errors, we add an error to the bag
640 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
643 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
644 qNewName s = do { u <- newUnique
646 ; return (TH.mkNameU s i) }
648 qReport True msg = addErr (text msg)
649 qReport False msg = addReport (text msg)
651 qLocation = do { m <- getModule
653 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
654 , TH.loc_module = moduleNameString (moduleName m)
655 , TH.loc_package = packageIdString (modulePackageId m)
656 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
657 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
661 -- For qRecover, discard error messages if
662 -- the recovery action is chosen. Otherwise
663 -- we'll only fail higher up. c.f. tryTcLIE_
664 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
666 Just val -> do { addMessages msgs -- There might be warnings
668 Nothing -> recover -- Discard all msgs
671 qRunIO io = liftIO io
675 %************************************************************************
677 \subsection{Errors and contexts}
679 %************************************************************************
682 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
683 showSplice what before after = do
685 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
686 nest 2 (sep [nest 2 (ppr before),
691 = ptext SLIT("Illegal bracket at level") <+> ppr level
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"
722 lookupThName :: TH.Name -> TcM Name
723 lookupThName th_name@(TH.Name occ flavour)
724 = do { let rdr_name = thRdrName guessed_ns occ_str flavour
726 -- Repeat much of lookupOccRn, becase we want
727 -- to report errors in a TH-relevant way
728 ; rdr_env <- getLocalRdrEnv
729 ; case lookupLocalRdrEnv rdr_env rdr_name of
730 Just name -> return name
731 Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
732 -> lookupImportedName rdr_name
733 | otherwise -- Unqual, Qual
734 -> do { mb_name <- lookupSrcOcc_maybe rdr_name
736 Just name -> return name
737 Nothing -> failWithTc (notInScope th_name) }
740 -- guessed_ns is the name space guessed from looking at the TH name
741 guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName
742 | otherwise = OccName.varName
743 occ_str = TH.occString occ
745 tcLookupTh :: Name -> TcM TcTyThing
746 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
747 -- it gives a reify-related error message on failure, whereas in the normal
748 -- tcLookup, failure is a bug.
750 = do { (gbl_env, lcl_env) <- getEnvs
751 ; case lookupNameEnv (tcl_env lcl_env) name of {
752 Just thing -> return thing;
754 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
755 then -- It's defined in this module
756 case lookupNameEnv (tcg_type_env gbl_env) name of
757 Just thing -> return (AGlobal thing)
758 Nothing -> failWithTc (notInEnv name)
760 else do -- It's imported
761 { (eps,hpt) <- getEpsAndHpt
763 ; case lookupType dflags hpt (eps_PTE eps) name of
764 Just thing -> return (AGlobal thing)
765 Nothing -> do { thing <- tcImportDecl name
766 ; return (AGlobal thing) }
767 -- Imported names should always be findable;
768 -- if not, we fail hard in tcImportDecl
771 notInScope :: TH.Name -> SDoc
772 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
773 ptext SLIT("is not in scope at a reify")
774 -- Ugh! Rather an indirect way to display the name
776 notInEnv :: Name -> SDoc
777 notInEnv name = quotes (ppr name) <+>
778 ptext SLIT("is not in the type environment at a reify")
780 ------------------------------
781 reifyThing :: TcTyThing -> TcM TH.Info
782 -- The only reason this is monadic is for error reporting,
783 -- which in turn is mainly for the case when TH can't express
784 -- some random GHC extension
786 reifyThing (AGlobal (AnId id))
787 = do { ty <- reifyType (idType id)
788 ; fix <- reifyFixity (idName id)
789 ; let v = reifyName id
790 ; case globalIdDetails id of
791 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
792 other -> return (TH.VarI v ty Nothing fix)
795 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
796 reifyThing (AGlobal (AClass cls)) = reifyClass cls
797 reifyThing (AGlobal (ADataCon dc))
798 = do { let name = dataConName dc
799 ; ty <- reifyType (idType (dataConWrapId dc))
800 ; fix <- reifyFixity name
801 ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
803 reifyThing (ATcId {tct_id = id, tct_type = ty})
804 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
805 -- though it may be incomplete
806 ; ty2 <- reifyType ty1
807 ; fix <- reifyFixity (idName id)
808 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
810 reifyThing (ATyVar tv ty)
811 = do { ty1 <- zonkTcType ty
812 ; ty2 <- reifyType ty1
813 ; return (TH.TyVarI (reifyName tv) ty2) }
815 ------------------------------
816 reifyTyCon :: TyCon -> TcM TH.Info
818 | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
819 | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
821 = do { let (tvs, rhs) = synTyConDefn tc
822 ; rhs' <- reifyType rhs
823 ; return (TH.TyConI $
824 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
827 = do { cxt <- reifyCxt (tyConStupidTheta tc)
828 ; let tvs = tyConTyVars tc
829 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
830 ; let name = reifyName tc
831 r_tvs = reifyTyVars tvs
832 deriv = [] -- Don't know about deriving
833 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
834 | otherwise = TH.DataD cxt name r_tvs cons deriv
835 ; return (TH.TyConI decl) }
837 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
839 | isVanillaDataCon dc
840 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
841 ; let stricts = map reifyStrict (dataConStrictMarks dc)
842 fields = dataConFieldLabels dc
846 ; ASSERT( length arg_tys == length stricts )
847 if not (null fields) then
848 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
850 if dataConIsInfix dc then
851 ASSERT( length arg_tys == 2 )
852 return (TH.InfixC (s1,a1) name (s2,a2))
854 return (TH.NormalC name (stricts `zip` arg_tys)) }
856 = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:")
859 ------------------------------
860 reifyClass :: Class -> TcM TH.Info
862 = do { cxt <- reifyCxt theta
863 ; ops <- mapM reify_op op_stuff
864 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
866 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
867 fds' = map reifyFunDep fds
868 reify_op (op, _) = do { ty <- reifyType (idType op)
869 ; return (TH.SigD (reifyName op) ty) }
871 ------------------------------
872 reifyType :: TypeRep.Type -> TcM TH.Type
873 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
874 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
875 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
876 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
877 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
878 ; tau' <- reifyType tau
879 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
881 (tvs, cxt, tau) = tcSplitSigmaTy ty
882 reifyTypes = mapM reifyType
883 reifyCxt = mapM reifyPred
885 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
886 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
888 reifyTyVars :: [TyVar] -> [TH.Name]
889 reifyTyVars = map reifyName
891 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
892 reify_tc_app tc tys = do { tys' <- reifyTypes tys
893 ; return (foldl TH.AppT (TH.ConT tc) tys') }
895 reifyPred :: TypeRep.PredType -> TcM TH.Type
896 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
897 reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p)
900 ------------------------------
901 reifyName :: NamedThing n => n -> TH.Name
903 | isExternalName name = mk_varg pkg_str mod_str occ_str
904 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
905 -- Many of the things we reify have local bindings, and
906 -- NameL's aren't supposed to appear in binding positions, so
907 -- we use NameU. When/if we start to reify nested things, that
908 -- have free variables, we may need to generate NameL's for them.
911 mod = nameModule name
912 pkg_str = packageIdString (modulePackageId mod)
913 mod_str = moduleNameString (moduleName mod)
914 occ_str = occNameString occ
915 occ = nameOccName name
916 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
917 | OccName.isVarOcc occ = TH.mkNameG_v
918 | OccName.isTcOcc occ = TH.mkNameG_tc
919 | otherwise = pprPanic "reifyName" (ppr name)
921 ------------------------------
922 reifyFixity :: Name -> TcM TH.Fixity
924 = do { fix <- lookupFixityRn name
925 ; return (conv_fix fix) }
927 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
928 conv_dir BasicTypes.InfixR = TH.InfixR
929 conv_dir BasicTypes.InfixL = TH.InfixL
930 conv_dir BasicTypes.InfixN = TH.InfixN
932 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
933 reifyStrict MarkedStrict = TH.IsStrict
934 reifyStrict MarkedUnboxed = TH.IsStrict
935 reifyStrict NotMarkedStrict = TH.NotStrict
937 ------------------------------
938 noTH :: LitString -> SDoc -> TcM a
939 noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+>
940 ptext SLIT("in Template Haskell:"),