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
202 = getStage `thenM` \ level ->
203 case bracketOK level of {
204 Nothing -> failWithTc (illegalBracket level) ;
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 newMutVar [] `thenM` \ pending_splices ->
212 getLIEVar `thenM` \ lie_var ->
214 setStage (Brack next_level pending_splices lie_var) (
215 getLIE (tc_bracket next_level brack)
216 ) `thenM` \ (meta_ty, lie) ->
217 tcSimplifyBracket lie `thenM_`
219 -- Make the expected type have the right shape
220 boxyUnify meta_ty res_ty `thenM_`
222 -- Return the original expression, not the type-decorated one
223 readMutVar pending_splices `thenM` \ pendings ->
224 returnM (noLoc (HsBracketOut brack pendings))
227 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
228 tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
229 = do { thing <- tcLookup name
231 AGlobal _ -> return ()
232 ATcId { tct_level = bind_lvl, tct_id = id }
233 | thTopLevelId id -- C.f thTopLevelId case of
234 -> keepAliveTc id -- TcExpr.thBrackId
236 -> do { checkTc (use_lvl == bind_lvl)
237 (quotedNameStageErr name) }
238 other -> pprPanic "th_bracket" (ppr name)
240 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
243 tc_bracket use_lvl (ExpBr expr)
244 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
245 ; tcMonoExpr expr any_ty
246 ; tcMetaTy expQTyConName }
247 -- Result type is Expr (= Q Exp)
249 tc_bracket use_lvl (TypBr typ)
250 = do { tcHsSigType ExprSigCtxt typ
251 ; tcMetaTy typeQTyConName }
252 -- Result type is Type (= Q Typ)
254 tc_bracket use_lvl (DecBr decls)
255 = do { tcTopSrcDecls emptyModDetails decls
256 -- Typecheck the declarations, dicarding the result
257 -- We'll get all that stuff later, when we splice it in
259 ; decl_ty <- tcMetaTy decTyConName
260 ; q_ty <- tcMetaTy qTyConName
261 ; return (mkAppTy q_ty (mkListTy decl_ty))
262 -- Result type is Q [Dec]
265 tc_bracket use_lvl (PatBr _)
266 = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet"))
269 = sep [ ptext SLIT("Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
270 , ptext SLIT("must be used at the same stage at which is is bound")]
274 %************************************************************************
276 \subsection{Splicing an expression}
278 %************************************************************************
281 tcSpliceExpr (HsSplice name expr) res_ty
282 = setSrcSpan (getLoc expr) $
283 getStage `thenM` \ level ->
284 case spliceOK level of {
285 Nothing -> failWithTc (illegalSplice level) ;
289 Comp -> do { e <- tcTopSplice expr res_ty
290 ; returnM (unLoc e) } ;
291 Brack _ ps_var lie_var ->
293 -- A splice inside brackets
294 -- NB: ignore res_ty, apart from zapping it to a mono-type
295 -- e.g. [| reverse $(h 4) |]
296 -- Here (h 4) :: Q Exp
297 -- but $(h 4) :: forall a.a i.e. anything!
299 unBox res_ty `thenM_`
300 tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
301 setStage (Splice next_level) (
303 tcMonoExpr expr meta_exp_ty
306 -- Write the pending splice into the bucket
307 readMutVar ps_var `thenM` \ ps ->
308 writeMutVar ps_var ((name,expr') : ps) `thenM_`
310 returnM (panic "tcSpliceExpr") -- The returned expression is ignored
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
322 = tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
324 -- Typecheck the expression
325 tcTopSpliceExpr expr meta_exp_ty `thenM` \ zonked_q_expr ->
327 -- Run the expression
328 traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
329 runMetaE convertToHsExpr zonked_q_expr `thenM` \ expr2 ->
331 traceTc (text "Got result" <+> ppr expr2) `thenM_`
333 showSplice "expression"
334 zonked_q_expr (ppr expr2) `thenM_`
336 -- Rename it, but bale out if there are errors
337 -- otherwise the type checker just gives more spurious errors
338 checkNoErrs (rnLExpr expr2) `thenM` \ (exp3, fvs) ->
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 quoter
435 = sep [ptext SLIT("GHC stage restriction:") <+> ppr quoter,
436 nest 2 (ptext SLIT("is used in a quasiquote, and must be imported, not defined locally"))]
440 %************************************************************************
444 %************************************************************************
446 Very like splicing an expression, but we don't yet share code.
449 kcSpliceType (HsSplice name hs_expr)
450 = setSrcSpan (getLoc hs_expr) $ do
452 ; case spliceOK level of {
453 Nothing -> failWithTc (illegalSplice level) ;
454 Just next_level -> do
457 Comp -> do { (t,k) <- kcTopSpliceType hs_expr
458 ; return (unLoc t, k) } ;
459 Brack _ ps_var lie_var -> do
461 { -- A splice inside brackets
462 ; meta_ty <- tcMetaTy typeQTyConName
463 ; expr' <- setStage (Splice next_level) $
465 tcMonoExpr hs_expr meta_ty
467 -- Write the pending splice into the bucket
468 ; ps <- readMutVar ps_var
469 ; writeMutVar ps_var ((name,expr') : ps)
471 -- e.g. [| Int -> $(h 4) |]
472 -- Here (h 4) :: Q Type
473 -- but $(h 4) :: forall a.a i.e. any kind
475 ; returnM (panic "kcSpliceType", kind) -- The returned type is ignored
478 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
480 = do { meta_ty <- tcMetaTy typeQTyConName
482 -- Typecheck the expression
483 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
485 -- Run the expression
486 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
487 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
489 ; traceTc (text "Got result" <+> ppr hs_ty2)
491 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
493 -- Rename it, but bale out if there are errors
494 -- otherwise the type checker just gives more spurious errors
495 ; let doc = ptext SLIT("In the spliced type") <+> ppr hs_ty2
496 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
501 %************************************************************************
503 \subsection{Splicing an expression}
505 %************************************************************************
508 -- Always at top level
509 -- Type sig at top of file:
510 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
512 = do { meta_dec_ty <- tcMetaTy decTyConName
513 ; meta_q_ty <- tcMetaTy qTyConName
514 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
515 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
517 -- Run the expression
518 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
519 ; decls <- runMetaD convertToHsDecls zonked_q_expr
521 ; traceTc (text "Got result" <+> vcat (map ppr decls))
522 ; showSplice "declarations"
524 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
527 where handleErrors :: [Either a Message] -> TcM [a]
528 handleErrors [] = return []
529 handleErrors (Left x:xs) = liftM (x:) (handleErrors xs)
530 handleErrors (Right m:xs) = do addErrTc m
535 %************************************************************************
537 \subsection{Running an expression}
539 %************************************************************************
542 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
543 -> LHsExpr Id -- Of type (Q Exp)
544 -> TcM (LHsExpr RdrName)
547 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
548 -> LHsExpr Id -- Of type (Q Pat)
552 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
553 -> LHsExpr Id -- Of type (Q Type)
554 -> TcM (LHsType RdrName)
557 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
558 -> LHsExpr Id -- Of type Q [Dec]
559 -> TcM [LHsDecl RdrName]
562 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
563 -> LHsExpr Id -- Of type X
564 -> TcM hs_syn -- Of type t
567 ds_expr <- initDsTc (dsLExpr expr)
568 -- Compile and link it; might fail if linking fails
569 ; hsc_env <- getTopEnv
570 ; src_span <- getSrcSpanM
571 ; either_hval <- tryM $ ioToTcRn $
572 HscMain.compileExpr hsc_env src_span ds_expr
573 ; case either_hval of {
574 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
577 { -- Coerce it to Q t, and run it
579 -- Running might fail if it throws an exception of any kind (hence tryAllM)
580 -- including, say, a pattern-match exception in the code we are running
582 -- We also do the TH -> HS syntax conversion inside the same
583 -- exception-cacthing thing so that if there are any lurking
584 -- exceptions in the data structure returned by hval, we'll
585 -- encounter them inside the try
587 -- See Note [Exceptions in TH]
588 let expr_span = getLoc expr
589 ; either_tval <- tryAllM $
590 setSrcSpan expr_span $ -- Set the span so that qLocation can
591 -- see where this splice is
592 do { th_syn <- TH.runQ (unsafeCoerce# hval)
593 ; case convert expr_span th_syn of
594 Left err -> failWithTc err
595 Right hs_syn -> return hs_syn }
597 ; case either_tval of
599 Left exn | Just s <- Exception.userErrors exn
600 , s == "IOEnv failure"
601 -> failM -- Error already in Tc monad
602 | otherwise -> failWithTc (mk_msg "run" exn) -- Exception
605 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
606 nest 2 (text (Panic.showException exn)),
607 nest 2 (text "Code:" <+> ppr expr)]
610 Note [Exceptions in TH]
611 ~~~~~~~~~~~~~~~~~~~~~~~
612 Supppose we have something like this
616 f n | n>3 = fail "Too many declarations"
619 The 'fail' is a user-generated failure, and should be displayed as a
620 perfectly ordinary compiler error message, not a panic or anything
621 like that. Here's how it's processed:
623 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
624 effectively transforms (fail s) to
625 qReport True s >> fail
626 where 'qReport' comes from the Quasi class and fail from its monad
629 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
630 (qReport True s) by using addErr to add an error message to the bag of errors.
631 The 'fail' in TcM raises a UserError, with the uninteresting string
634 * So, when running a splice, we catch all exceptions; then for
635 - a UserError "IOEnv failure", we assume the error is already
636 in the error-bag (above)
637 - other errors, we add an error to the bag
641 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
644 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
645 qNewName s = do { u <- newUnique
647 ; return (TH.mkNameU s i) }
649 qReport True msg = addErr (text msg)
650 qReport False msg = addReport (text msg)
652 qLocation = do { m <- getModule
654 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
655 , TH.loc_module = moduleNameString (moduleName m)
656 , TH.loc_package = packageIdString (modulePackageId m)
657 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
658 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
662 -- For qRecover, discard error messages if
663 -- the recovery action is chosen. Otherwise
664 -- we'll only fail higher up. c.f. tryTcLIE_
665 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
667 Just val -> do { addMessages msgs -- There might be warnings
669 Nothing -> recover -- Discard all msgs
672 qRunIO io = ioToTcRn io
676 %************************************************************************
678 \subsection{Errors and contexts}
680 %************************************************************************
683 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
684 showSplice what before after
685 = getSrcSpanM `thenM` \ loc ->
686 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
687 nest 2 (sep [nest 2 (ppr before),
692 = ptext SLIT("Illegal bracket at level") <+> ppr level
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"
723 lookupThName :: TH.Name -> TcM Name
724 lookupThName th_name@(TH.Name occ flavour)
725 = do { let rdr_name = thRdrName guessed_ns occ_str flavour
727 -- Repeat much of lookupOccRn, becase we want
728 -- to report errors in a TH-relevant way
729 ; rdr_env <- getLocalRdrEnv
730 ; case lookupLocalRdrEnv rdr_env rdr_name of
731 Just name -> return name
732 Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
733 -> lookupImportedName rdr_name
734 | otherwise -- Unqual, Qual
735 -> do { mb_name <- lookupSrcOcc_maybe rdr_name
737 Just name -> return name
738 Nothing -> failWithTc (notInScope th_name) }
741 -- guessed_ns is the name space guessed from looking at the TH name
742 guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName
743 | otherwise = OccName.varName
744 occ_str = TH.occString occ
746 tcLookupTh :: Name -> TcM TcTyThing
747 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
748 -- it gives a reify-related error message on failure, whereas in the normal
749 -- tcLookup, failure is a bug.
751 = do { (gbl_env, lcl_env) <- getEnvs
752 ; case lookupNameEnv (tcl_env lcl_env) name of {
753 Just thing -> returnM thing;
755 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
756 then -- It's defined in this module
757 case lookupNameEnv (tcg_type_env gbl_env) name of
758 Just thing -> return (AGlobal thing)
759 Nothing -> failWithTc (notInEnv name)
761 else do -- It's imported
762 { (eps,hpt) <- getEpsAndHpt
764 ; case lookupType dflags hpt (eps_PTE eps) name of
765 Just thing -> return (AGlobal thing)
766 Nothing -> do { thing <- tcImportDecl name
767 ; return (AGlobal thing) }
768 -- Imported names should always be findable;
769 -- if not, we fail hard in tcImportDecl
772 notInScope :: TH.Name -> SDoc
773 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
774 ptext SLIT("is not in scope at a reify")
775 -- Ugh! Rather an indirect way to display the name
777 notInEnv :: Name -> SDoc
778 notInEnv name = quotes (ppr name) <+>
779 ptext SLIT("is not in the type environment at a reify")
781 ------------------------------
782 reifyThing :: TcTyThing -> TcM TH.Info
783 -- The only reason this is monadic is for error reporting,
784 -- which in turn is mainly for the case when TH can't express
785 -- some random GHC extension
787 reifyThing (AGlobal (AnId id))
788 = do { ty <- reifyType (idType id)
789 ; fix <- reifyFixity (idName id)
790 ; let v = reifyName id
791 ; case globalIdDetails id of
792 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
793 other -> return (TH.VarI v ty Nothing fix)
796 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
797 reifyThing (AGlobal (AClass cls)) = reifyClass cls
798 reifyThing (AGlobal (ADataCon dc))
799 = do { let name = dataConName dc
800 ; ty <- reifyType (idType (dataConWrapId dc))
801 ; fix <- reifyFixity name
802 ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
804 reifyThing (ATcId {tct_id = id, tct_type = ty})
805 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
806 -- though it may be incomplete
807 ; ty2 <- reifyType ty1
808 ; fix <- reifyFixity (idName id)
809 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
811 reifyThing (ATyVar tv ty)
812 = do { ty1 <- zonkTcType ty
813 ; ty2 <- reifyType ty1
814 ; return (TH.TyVarI (reifyName tv) ty2) }
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 (NoteTy _ ty) = reifyType ty
877 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
878 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
879 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
880 ; tau' <- reifyType tau
881 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
883 (tvs, cxt, tau) = tcSplitSigmaTy ty
884 reifyTypes = mapM reifyType
885 reifyCxt = mapM reifyPred
887 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
888 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
890 reifyTyVars :: [TyVar] -> [TH.Name]
891 reifyTyVars = map reifyName
893 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
894 reify_tc_app tc tys = do { tys' <- reifyTypes tys
895 ; return (foldl TH.AppT (TH.ConT tc) tys') }
897 reifyPred :: TypeRep.PredType -> TcM TH.Type
898 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
899 reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p)
902 ------------------------------
903 reifyName :: NamedThing n => n -> TH.Name
905 | isExternalName name = mk_varg pkg_str mod_str occ_str
906 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
907 -- Many of the things we reify have local bindings, and
908 -- NameL's aren't supposed to appear in binding positions, so
909 -- we use NameU. When/if we start to reify nested things, that
910 -- have free variables, we may need to generate NameL's for them.
913 mod = nameModule name
914 pkg_str = packageIdString (modulePackageId mod)
915 mod_str = moduleNameString (moduleName mod)
916 occ_str = occNameString occ
917 occ = nameOccName name
918 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
919 | OccName.isVarOcc occ = TH.mkNameG_v
920 | OccName.isTcOcc occ = TH.mkNameG_tc
921 | otherwise = pprPanic "reifyName" (ppr name)
923 ------------------------------
924 reifyFixity :: Name -> TcM TH.Fixity
926 = do { fix <- lookupFixityRn name
927 ; return (conv_fix fix) }
929 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
930 conv_dir BasicTypes.InfixR = TH.InfixR
931 conv_dir BasicTypes.InfixL = TH.InfixL
932 conv_dir BasicTypes.InfixN = TH.InfixN
934 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
935 reifyStrict MarkedStrict = TH.IsStrict
936 reifyStrict MarkedUnboxed = TH.IsStrict
937 reifyStrict NotMarkedStrict = TH.NotStrict
939 ------------------------------
940 noTH :: LitString -> SDoc -> TcM a
941 noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+>
942 ptext SLIT("in Template Haskell:"),