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 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
161 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
162 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
163 -- None of these functions add constraints to the LIE
165 runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
166 runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
169 tcSpliceExpr _ e _ = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
170 tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
172 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
173 runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
177 %************************************************************************
179 \subsection{Quoting an expression}
181 %************************************************************************
183 Note [Handling brackets]
184 ~~~~~~~~~~~~~~~~~~~~~~~~
185 Source: f = [| Just $(g 3) |]
186 The [| |] part is a HsBracket
188 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
189 The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
190 The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
192 Desugared: f = do { s7 <- g Int 3
193 ; return (ConE "Data.Maybe.Just" s7) }
196 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
197 tcBracket brack res_ty = do
199 case bracketOK level of {
200 Nothing -> failWithTc (illegalBracket level) ;
201 Just next_level -> do
203 -- Typecheck expr to make sure it is valid,
204 -- but throw away the results. We'll type check
205 -- it again when we actually use it.
207 pending_splices <- newMutVar []
210 (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
211 (getLIE (tc_bracket next_level brack))
212 tcSimplifyBracket lie
214 -- Make the expected type have the right shape
215 boxyUnify meta_ty res_ty
217 -- Return the original expression, not the type-decorated one
218 pendings <- readMutVar pending_splices
219 return (noLoc (HsBracketOut brack pendings))
222 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
223 tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
224 = do { thing <- tcLookup name
226 AGlobal _ -> return ()
227 ATcId { tct_level = bind_lvl, tct_id = id }
228 | thTopLevelId id -- C.f thTopLevelId case of
229 -> keepAliveTc id -- TcExpr.thBrackId
231 -> do { checkTc (use_lvl == bind_lvl)
232 (quotedNameStageErr name) }
233 _ -> pprPanic "th_bracket" (ppr name)
235 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
238 tc_bracket _ (ExpBr expr)
239 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
240 ; tcMonoExpr expr any_ty
241 ; tcMetaTy expQTyConName }
242 -- Result type is Expr (= Q Exp)
244 tc_bracket _ (TypBr typ)
245 = do { tcHsSigType ExprSigCtxt typ
246 ; tcMetaTy typeQTyConName }
247 -- Result type is Type (= Q Typ)
249 tc_bracket _ (DecBr decls)
250 = do { tcTopSrcDecls emptyModDetails decls
251 -- Typecheck the declarations, dicarding the result
252 -- We'll get all that stuff later, when we splice it in
254 ; decl_ty <- tcMetaTy decTyConName
255 ; q_ty <- tcMetaTy qTyConName
256 ; return (mkAppTy q_ty (mkListTy decl_ty))
257 -- Result type is Q [Dec]
260 tc_bracket _ (PatBr _)
261 = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
263 quotedNameStageErr :: Name -> SDoc
265 = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
266 , ptext (sLit "must be used at the same stage at which is is bound")]
270 %************************************************************************
272 \subsection{Splicing an expression}
274 %************************************************************************
277 tcSpliceExpr (HsSplice name expr) res_ty
278 = setSrcSpan (getLoc expr) $ do
280 case spliceOK level of {
281 Nothing -> failWithTc (illegalSplice level) ;
285 Comp -> do { e <- tcTopSplice expr res_ty
286 ; return (unLoc e) } ;
287 Brack _ ps_var lie_var -> do
289 -- A splice inside brackets
290 -- NB: ignore res_ty, apart from zapping it to a mono-type
291 -- e.g. [| reverse $(h 4) |]
292 -- Here (h 4) :: Q Exp
293 -- but $(h 4) :: forall a.a i.e. anything!
296 meta_exp_ty <- tcMetaTy expQTyConName
297 expr' <- setStage (Splice next_level) (
299 tcMonoExpr expr meta_exp_ty
302 -- Write the pending splice into the bucket
303 ps <- readMutVar ps_var
304 writeMutVar ps_var ((name,expr') : ps)
306 return (panic "tcSpliceExpr") -- The returned expression is ignored
308 ; Splice {} -> panic "tcSpliceExpr Splice"
311 -- tcTopSplice used to have this:
312 -- Note that we do not decrement the level (to -1) before
313 -- typechecking the expression. For example:
314 -- f x = $( ...$(g 3) ... )
315 -- The recursive call to tcMonoExpr will simply expand the
316 -- inner escape before dealing with the outer one
318 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
319 tcTopSplice expr res_ty = do
320 meta_exp_ty <- tcMetaTy expQTyConName
322 -- Typecheck the expression
323 zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
325 -- Run the expression
326 traceTc (text "About to run" <+> ppr zonked_q_expr)
327 expr2 <- runMetaE convertToHsExpr zonked_q_expr
329 traceTc (text "Got result" <+> ppr expr2)
331 showSplice "expression"
332 zonked_q_expr (ppr expr2)
334 -- Rename it, but bale out if there are errors
335 -- otherwise the type checker just gives more spurious errors
336 (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
338 tcMonoExpr exp3 res_ty
341 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
342 -- Type check an expression that is the body of a top-level splice
343 -- (the caller will compile and run it)
344 tcTopSpliceExpr expr meta_ty
345 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
346 -- if the type checker fails!
348 setStage topSpliceStage $ do
351 do { recordThUse -- Record that TH is used (for pkg depdendency)
353 -- Typecheck the expression
354 ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
356 -- Solve the constraints
357 ; const_binds <- tcSimplifyTop lie
360 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
364 %************************************************************************
368 %************************************************************************
370 Note [Quasi-quote overview]
371 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
372 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
373 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
378 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
379 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
380 defined in another module, because we are going to run it here. It's
381 a bit like a TH splice:
384 However, you can do this in patterns as well as terms. Becuase of this,
385 the splice is run by the *renamer* rather than the type checker.
388 runQuasiQuote :: Outputable hs_syn
389 => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
390 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
391 -> String -- Documentation string only
392 -> Name -- Name of th_syn type
393 -> (SrcSpan -> th_syn -> Either Message hs_syn)
395 runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
396 = do { -- Check that the quoter is not locally defined, otherwise the TH
397 -- machinery will not be able to run the quasiquote.
398 ; this_mod <- getModule
399 ; let is_local = case nameModule_maybe quoter of
400 Just mod | mod == this_mod -> True
403 ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
404 ; checkTc (not is_local) (quoteStageError quoter)
406 -- Build the expression
407 ; let quoterExpr = L q_span $! HsVar $! quoter
408 ; let quoteExpr = L q_span $! HsLit $! HsString quote
409 ; let expr = L q_span $
411 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
413 ; meta_exp_ty <- tcMetaTy meta_ty
415 -- Typecheck the expression
416 ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
418 -- Run the expression
419 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
420 ; result <- runMeta convert zonked_q_expr
421 ; traceTc (text "Got result" <+> ppr result)
422 ; showSplice desc zonked_q_expr (ppr result)
426 runQuasiQuoteExpr quasiquote
427 = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
429 runQuasiQuotePat quasiquote
430 = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
432 quoteStageError :: Name -> SDoc
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
476 ; Splice {} -> panic "kcSpliceType Splice"
479 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
481 = do { meta_ty <- tcMetaTy typeQTyConName
483 -- Typecheck the expression
484 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
486 -- Run the expression
487 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
488 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
490 ; traceTc (text "Got result" <+> ppr hs_ty2)
492 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
494 -- Rename it, but bale out if there are errors
495 -- otherwise the type checker just gives more spurious errors
496 ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
497 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
502 %************************************************************************
504 \subsection{Splicing an expression}
506 %************************************************************************
509 -- Always at top level
510 -- Type sig at top of file:
511 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
513 = do { meta_dec_ty <- tcMetaTy decTyConName
514 ; meta_q_ty <- tcMetaTy qTyConName
515 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
516 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
518 -- Run the expression
519 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
520 ; decls <- runMetaD convertToHsDecls zonked_q_expr
522 ; traceTc (text "Got result" <+> vcat (map ppr decls))
523 ; showSplice "declarations"
525 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
530 %************************************************************************
532 \subsection{Running an expression}
534 %************************************************************************
537 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
538 -> LHsExpr Id -- Of type (Q Exp)
539 -> TcM (LHsExpr RdrName)
542 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
543 -> LHsExpr Id -- Of type (Q Pat)
547 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
548 -> LHsExpr Id -- Of type (Q Type)
549 -> TcM (LHsType RdrName)
552 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
553 -> LHsExpr Id -- Of type Q [Dec]
554 -> TcM [LHsDecl RdrName]
557 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
558 -> LHsExpr Id -- Of type X
559 -> TcM hs_syn -- Of type t
562 ds_expr <- initDsTc (dsLExpr expr)
563 -- Compile and link it; might fail if linking fails
564 ; hsc_env <- getTopEnv
565 ; src_span <- getSrcSpanM
566 ; either_hval <- tryM $ liftIO $
567 HscMain.compileExpr hsc_env src_span ds_expr
568 ; case either_hval of {
569 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
572 { -- Coerce it to Q t, and run it
574 -- Running might fail if it throws an exception of any kind (hence tryAllM)
575 -- including, say, a pattern-match exception in the code we are running
577 -- We also do the TH -> HS syntax conversion inside the same
578 -- exception-cacthing thing so that if there are any lurking
579 -- exceptions in the data structure returned by hval, we'll
580 -- encounter them inside the try
582 -- See Note [Exceptions in TH]
583 let expr_span = getLoc expr
584 ; either_tval <- tryAllM $
585 setSrcSpan expr_span $ -- Set the span so that qLocation can
586 -- see where this splice is
587 do { th_syn <- TH.runQ (unsafeCoerce# hval)
588 ; case convert expr_span th_syn of
589 Left err -> failWithTc err
590 Right hs_syn -> return hs_syn }
592 ; case either_tval of
594 Left exn | Just s <- Exception.userErrors exn
595 , s == "IOEnv failure"
596 -> failM -- Error already in Tc monad
597 | otherwise -> failWithTc (mk_msg "run" exn) -- Exception
600 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
601 nest 2 (text (Panic.showException exn)),
602 nest 2 (text "Code:" <+> ppr expr)]
605 Note [Exceptions in TH]
606 ~~~~~~~~~~~~~~~~~~~~~~~
607 Supppose we have something like this
611 f n | n>3 = fail "Too many declarations"
614 The 'fail' is a user-generated failure, and should be displayed as a
615 perfectly ordinary compiler error message, not a panic or anything
616 like that. Here's how it's processed:
618 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
619 effectively transforms (fail s) to
620 qReport True s >> fail
621 where 'qReport' comes from the Quasi class and fail from its monad
624 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
625 (qReport True s) by using addErr to add an error message to the bag of errors.
626 The 'fail' in TcM raises a UserError, with the uninteresting string
629 * So, when running a splice, we catch all exceptions; then for
630 - a UserError "IOEnv failure", we assume the error is already
631 in the error-bag (above)
632 - other errors, we add an error to the bag
636 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
639 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
640 qNewName s = do { u <- newUnique
642 ; return (TH.mkNameU s i) }
644 qReport True msg = addErr (text msg)
645 qReport False msg = addReport (text msg)
647 qLocation = do { m <- getModule
649 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
650 , TH.loc_module = moduleNameString (moduleName m)
651 , TH.loc_package = packageIdString (modulePackageId m)
652 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
653 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
657 -- For qRecover, discard error messages if
658 -- the recovery action is chosen. Otherwise
659 -- we'll only fail higher up. c.f. tryTcLIE_
660 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
662 Just val -> do { addMessages msgs -- There might be warnings
664 Nothing -> recover -- Discard all msgs
667 qRunIO io = liftIO io
671 %************************************************************************
673 \subsection{Errors and contexts}
675 %************************************************************************
678 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
679 showSplice what before after = do
681 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
682 nest 2 (sep [nest 2 (ppr before),
686 illegalBracket :: ThStage -> SDoc
688 = ptext (sLit "Illegal bracket at level") <+> ppr level
690 illegalSplice :: ThStage -> SDoc
692 = ptext (sLit "Illegal splice at level") <+> ppr level
698 %************************************************************************
702 %************************************************************************
706 reify :: TH.Name -> TcM TH.Info
708 = do { name <- lookupThName th_name
709 ; thing <- tcLookupTh name
710 -- ToDo: this tcLookup could fail, which would give a
711 -- rather unhelpful error message
712 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
716 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
717 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
718 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
719 ppr_ns _ = panic "reify/ppr_ns"
721 lookupThName :: TH.Name -> TcM Name
722 lookupThName th_name@(TH.Name occ flavour)
723 = do { let rdr_name = thRdrName guessed_ns occ_str flavour
725 -- Repeat much of lookupOccRn, becase we want
726 -- to report errors in a TH-relevant way
727 ; rdr_env <- getLocalRdrEnv
728 ; case lookupLocalRdrEnv rdr_env rdr_name of
729 Just name -> return name
730 Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
731 -> lookupImportedName rdr_name
732 | otherwise -- Unqual, Qual
733 -> do { mb_name <- lookupSrcOcc_maybe rdr_name
735 Just name -> return name
736 Nothing -> failWithTc (notInScope th_name) }
739 -- guessed_ns is the name space guessed from looking at the TH name
740 guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName
741 | otherwise = OccName.varName
742 occ_str = TH.occString occ
744 tcLookupTh :: Name -> TcM TcTyThing
745 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
746 -- it gives a reify-related error message on failure, whereas in the normal
747 -- tcLookup, failure is a bug.
749 = do { (gbl_env, lcl_env) <- getEnvs
750 ; case lookupNameEnv (tcl_env lcl_env) name of {
751 Just thing -> return thing;
753 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
754 then -- It's defined in this module
755 case lookupNameEnv (tcg_type_env gbl_env) name of
756 Just thing -> return (AGlobal thing)
757 Nothing -> failWithTc (notInEnv name)
759 else do -- It's imported
760 { (eps,hpt) <- getEpsAndHpt
762 ; case lookupType dflags hpt (eps_PTE eps) name of
763 Just thing -> return (AGlobal thing)
764 Nothing -> do { thing <- tcImportDecl name
765 ; return (AGlobal thing) }
766 -- Imported names should always be findable;
767 -- if not, we fail hard in tcImportDecl
770 notInScope :: TH.Name -> SDoc
771 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
772 ptext (sLit "is not in scope at a reify")
773 -- Ugh! Rather an indirect way to display the name
775 notInEnv :: Name -> SDoc
776 notInEnv name = quotes (ppr name) <+>
777 ptext (sLit "is not in the type environment at a reify")
779 ------------------------------
780 reifyThing :: TcTyThing -> TcM TH.Info
781 -- The only reason this is monadic is for error reporting,
782 -- which in turn is mainly for the case when TH can't express
783 -- some random GHC extension
785 reifyThing (AGlobal (AnId id))
786 = do { ty <- reifyType (idType id)
787 ; fix <- reifyFixity (idName id)
788 ; let v = reifyName id
789 ; case globalIdDetails id of
790 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
791 _ -> return (TH.VarI v ty Nothing fix)
794 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
795 reifyThing (AGlobal (AClass cls)) = reifyClass cls
796 reifyThing (AGlobal (ADataCon dc))
797 = do { let name = dataConName dc
798 ; ty <- reifyType (idType (dataConWrapId dc))
799 ; fix <- reifyFixity name
800 ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
802 reifyThing (ATcId {tct_id = id, tct_type = ty})
803 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
804 -- though it may be incomplete
805 ; ty2 <- reifyType ty1
806 ; fix <- reifyFixity (idName id)
807 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
809 reifyThing (ATyVar tv ty)
810 = do { ty1 <- zonkTcType ty
811 ; ty2 <- reifyType ty1
812 ; return (TH.TyVarI (reifyName tv) ty2) }
814 reifyThing (AThing {}) = panic "reifyThing AThing"
816 ------------------------------
817 reifyTyCon :: TyCon -> TcM TH.Info
819 | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
820 | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
822 = do { let (tvs, rhs) = synTyConDefn tc
823 ; rhs' <- reifyType rhs
824 ; return (TH.TyConI $
825 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
828 = do { cxt <- reifyCxt (tyConStupidTheta tc)
829 ; let tvs = tyConTyVars tc
830 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
831 ; let name = reifyName tc
832 r_tvs = reifyTyVars tvs
833 deriv = [] -- Don't know about deriving
834 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
835 | otherwise = TH.DataD cxt name r_tvs cons deriv
836 ; return (TH.TyConI decl) }
838 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
840 | isVanillaDataCon dc
841 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
842 ; let stricts = map reifyStrict (dataConStrictMarks dc)
843 fields = dataConFieldLabels dc
847 ; ASSERT( length arg_tys == length stricts )
848 if not (null fields) then
849 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
851 if dataConIsInfix dc then
852 ASSERT( length arg_tys == 2 )
853 return (TH.InfixC (s1,a1) name (s2,a2))
855 return (TH.NormalC name (stricts `zip` arg_tys)) }
857 = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:")
860 ------------------------------
861 reifyClass :: Class -> TcM TH.Info
863 = do { cxt <- reifyCxt theta
864 ; ops <- mapM reify_op op_stuff
865 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
867 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
868 fds' = map reifyFunDep fds
869 reify_op (op, _) = do { ty <- reifyType (idType op)
870 ; return (TH.SigD (reifyName op) ty) }
872 ------------------------------
873 reifyType :: TypeRep.Type -> TcM TH.Type
874 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
875 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
876 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
877 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
878 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
879 ; tau' <- reifyType tau
880 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
882 (tvs, cxt, tau) = tcSplitSigmaTy ty
883 reifyType (PredTy {}) = panic "reifyType PredTy"
885 reifyTypes :: [Type] -> TcM [TH.Type]
886 reifyTypes = mapM reifyType
887 reifyCxt :: [PredType] -> TcM [TH.Type]
888 reifyCxt = mapM reifyPred
890 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
891 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
893 reifyTyVars :: [TyVar] -> [TH.Name]
894 reifyTyVars = map reifyName
896 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
897 reify_tc_app tc tys = do { tys' <- reifyTypes tys
898 ; return (foldl TH.AppT (TH.ConT tc) tys') }
900 reifyPred :: TypeRep.PredType -> TcM TH.Type
901 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
902 reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
903 reifyPred (EqPred {}) = panic "reifyPred EqPred"
906 ------------------------------
907 reifyName :: NamedThing n => n -> TH.Name
909 | isExternalName name = mk_varg pkg_str mod_str occ_str
910 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
911 -- Many of the things we reify have local bindings, and
912 -- NameL's aren't supposed to appear in binding positions, so
913 -- we use NameU. When/if we start to reify nested things, that
914 -- have free variables, we may need to generate NameL's for them.
917 mod = nameModule name
918 pkg_str = packageIdString (modulePackageId mod)
919 mod_str = moduleNameString (moduleName mod)
920 occ_str = occNameString occ
921 occ = nameOccName name
922 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
923 | OccName.isVarOcc occ = TH.mkNameG_v
924 | OccName.isTcOcc occ = TH.mkNameG_tc
925 | otherwise = pprPanic "reifyName" (ppr name)
927 ------------------------------
928 reifyFixity :: Name -> TcM TH.Fixity
930 = do { fix <- lookupFixityRn name
931 ; return (conv_fix fix) }
933 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
934 conv_dir BasicTypes.InfixR = TH.InfixR
935 conv_dir BasicTypes.InfixL = TH.InfixL
936 conv_dir BasicTypes.InfixN = TH.InfixN
938 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
939 reifyStrict MarkedStrict = TH.IsStrict
940 reifyStrict MarkedUnboxed = TH.IsStrict
941 reifyStrict NotMarkedStrict = TH.NotStrict
943 ------------------------------
944 noTH :: LitString -> SDoc -> TcM a
945 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
946 ptext (sLit "in Template Haskell:"),