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)
66 import Data.Typeable (cast)
69 import qualified Language.Haskell.TH as TH
70 -- THSyntax gives access to internal functions and data types
71 import qualified Language.Haskell.TH.Syntax as TH
73 import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
74 #if __GLASGOW_HASKELL__ < 609
75 import qualified Exception ( userErrors )
77 import System.IO.Error
81 Note [Template Haskell levels]
82 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
83 * Imported things are impLevel (= 0)
85 * In GHCi, variables bound by a previous command are treated
86 as impLevel, because we have bytecode for them.
88 * Variables are bound at the "current level"
90 * The current level starts off at topLevel (= 1)
92 * The level is decremented by splicing $(..)
93 incremented by brackets [| |]
94 incremented by name-quoting 'f
96 When a variable is used, we compare
97 bind: binding level, and
98 use: current level at usage site
101 bind > use Always error (bound later than used)
104 bind = use Always OK (bound same stage as used)
105 [| \x -> $(f [| x |]) |]
107 bind < use Inside brackets, it depends
111 For (bind < use) inside brackets, there are three cases:
112 - Imported things OK f = [| map |]
113 - Top-level things OK g = [| f |]
114 - Non-top-level Only if there is a liftable instance
115 h = \(x:Int) -> [| x |]
117 See Note [What is a top-level Id?]
121 A quoted name 'n is a bit like a quoted expression [| n |], except that we
122 have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
123 the use-level to account for the brackets, the cases are:
132 See Note [What is a top-level Id?] in TcEnv. Examples:
134 f 'map -- OK; also for top-level defns of this module
136 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
137 -- cross-stage lifting
139 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
141 [| \x. $(f 'x) |] -- OK
144 Note [What is a top-level Id?]
145 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
146 In the level-control criteria above, we need to know what a "top level Id" is.
147 There are three kinds:
148 * Imported from another module (GlobalId, ExternalName)
149 * Bound at the top level of this module (ExternalName)
150 * In GHCi, bound by a previous stmt (GlobalId)
151 It's strange that there is no one criterion tht picks out all three, but that's
152 how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids
153 bound in an earlier Stmt, but what module would you choose? See
154 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
156 The predicate we use is TcEnv.thTopLevelId.
159 %************************************************************************
161 \subsection{Main interface + stubs for the non-GHCI case
163 %************************************************************************
166 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
167 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
168 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
169 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
170 -- None of these functions add constraints to the LIE
172 runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
173 runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
176 tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
177 tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
178 tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
179 kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
181 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
182 runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
186 %************************************************************************
188 \subsection{Quoting an expression}
190 %************************************************************************
192 Note [Handling brackets]
193 ~~~~~~~~~~~~~~~~~~~~~~~~
194 Source: f = [| Just $(g 3) |]
195 The [| |] part is a HsBracket
197 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
198 The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
199 The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
201 Desugared: f = do { s7 <- g Int 3
202 ; return (ConE "Data.Maybe.Just" s7) }
205 tcBracket brack res_ty = do
207 case bracketOK level of {
208 Nothing -> failWithTc (illegalBracket level) ;
209 Just next_level -> do
211 -- Typecheck expr to make sure it is valid,
212 -- but throw away the results. We'll type check
213 -- it again when we actually use it.
215 pending_splices <- newMutVar []
218 (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
219 (getLIE (tc_bracket next_level brack))
220 tcSimplifyBracket lie
222 -- Make the expected type have the right shape
223 boxyUnify meta_ty res_ty
225 -- Return the original expression, not the type-decorated one
226 pendings <- readMutVar pending_splices
227 return (noLoc (HsBracketOut brack pendings))
230 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
231 tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
232 = do { thing <- tcLookup name
234 AGlobal _ -> return ()
235 ATcId { tct_level = bind_lvl, tct_id = id }
236 | thTopLevelId id -- C.f thTopLevelId case of
237 -> keepAliveTc id -- TcExpr.thBrackId
239 -> do { checkTc (use_lvl == bind_lvl)
240 (quotedNameStageErr name) }
241 _ -> pprPanic "th_bracket" (ppr name)
243 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
246 tc_bracket _ (ExpBr expr)
247 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
248 ; tcMonoExpr expr any_ty
249 ; tcMetaTy expQTyConName }
250 -- Result type is Expr (= Q Exp)
252 tc_bracket _ (TypBr typ)
253 = do { tcHsSigType ExprSigCtxt typ
254 ; tcMetaTy typeQTyConName }
255 -- Result type is Type (= Q Typ)
257 tc_bracket _ (DecBr decls)
258 = do { tcTopSrcDecls emptyModDetails decls
259 -- Typecheck the declarations, dicarding the result
260 -- We'll get all that stuff later, when we splice it in
262 ; decl_ty <- tcMetaTy decTyConName
263 ; q_ty <- tcMetaTy qTyConName
264 ; return (mkAppTy q_ty (mkListTy decl_ty))
265 -- Result type is Q [Dec]
268 tc_bracket _ (PatBr _)
269 = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
271 quotedNameStageErr :: Name -> SDoc
273 = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
274 , ptext (sLit "must be used at the same stage at which is is bound")]
278 %************************************************************************
280 \subsection{Splicing an expression}
282 %************************************************************************
285 tcSpliceExpr (HsSplice name expr) res_ty
286 = setSrcSpan (getLoc expr) $ do
288 case spliceOK level of {
289 Nothing -> failWithTc (illegalSplice level) ;
293 Comp -> do { e <- tcTopSplice expr res_ty
294 ; return (unLoc e) } ;
295 Brack _ ps_var lie_var -> do
297 -- A splice inside brackets
298 -- NB: ignore res_ty, apart from zapping it to a mono-type
299 -- e.g. [| reverse $(h 4) |]
300 -- Here (h 4) :: Q Exp
301 -- but $(h 4) :: forall a.a i.e. anything!
304 meta_exp_ty <- tcMetaTy expQTyConName
305 expr' <- setStage (Splice next_level) (
307 tcMonoExpr expr meta_exp_ty
310 -- Write the pending splice into the bucket
311 ps <- readMutVar ps_var
312 writeMutVar ps_var ((name,expr') : ps)
314 return (panic "tcSpliceExpr") -- The returned expression is ignored
316 ; Splice {} -> panic "tcSpliceExpr Splice"
319 -- tcTopSplice used to have this:
320 -- Note that we do not decrement the level (to -1) before
321 -- typechecking the expression. For example:
322 -- f x = $( ...$(g 3) ... )
323 -- The recursive call to tcMonoExpr will simply expand the
324 -- inner escape before dealing with the outer one
326 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
327 tcTopSplice expr res_ty = do
328 meta_exp_ty <- tcMetaTy expQTyConName
330 -- Typecheck the expression
331 zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
333 -- Run the expression
334 traceTc (text "About to run" <+> ppr zonked_q_expr)
335 expr2 <- runMetaE convertToHsExpr zonked_q_expr
337 traceTc (text "Got result" <+> ppr expr2)
339 showSplice "expression"
340 zonked_q_expr (ppr expr2)
342 -- Rename it, but bale out if there are errors
343 -- otherwise the type checker just gives more spurious errors
344 (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
346 tcMonoExpr exp3 res_ty
349 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
350 -- Type check an expression that is the body of a top-level splice
351 -- (the caller will compile and run it)
352 tcTopSpliceExpr expr meta_ty
353 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
354 -- if the type checker fails!
356 setStage topSpliceStage $ do
359 do { recordThUse -- Record that TH is used (for pkg depdendency)
361 -- Typecheck the expression
362 ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
364 -- Solve the constraints
365 ; const_binds <- tcSimplifyTop lie
368 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
372 %************************************************************************
376 %************************************************************************
378 Note [Quasi-quote overview]
379 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
380 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
381 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
386 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
387 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
388 defined in another module, because we are going to run it here. It's
389 a bit like a TH splice:
392 However, you can do this in patterns as well as terms. Becuase of this,
393 the splice is run by the *renamer* rather than the type checker.
396 runQuasiQuote :: Outputable hs_syn
397 => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
398 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
399 -> String -- Documentation string only
400 -> Name -- Name of th_syn type
401 -> (SrcSpan -> th_syn -> Either Message hs_syn)
403 runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
404 = do { -- Check that the quoter is not locally defined, otherwise the TH
405 -- machinery will not be able to run the quasiquote.
406 ; this_mod <- getModule
407 ; let is_local = case nameModule_maybe quoter of
408 Just mod | mod == this_mod -> True
411 ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
412 ; checkTc (not is_local) (quoteStageError quoter)
414 -- Build the expression
415 ; let quoterExpr = L q_span $! HsVar $! quoter
416 ; let quoteExpr = L q_span $! HsLit $! HsString quote
417 ; let expr = L q_span $
419 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
421 ; meta_exp_ty <- tcMetaTy meta_ty
423 -- Typecheck the expression
424 ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
426 -- Run the expression
427 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
428 ; result <- runMeta convert zonked_q_expr
429 ; traceTc (text "Got result" <+> ppr result)
430 ; showSplice desc zonked_q_expr (ppr result)
434 runQuasiQuoteExpr quasiquote
435 = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
437 runQuasiQuotePat quasiquote
438 = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
440 quoteStageError :: Name -> SDoc
441 quoteStageError quoter
442 = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
443 nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
447 %************************************************************************
451 %************************************************************************
453 Very like splicing an expression, but we don't yet share code.
456 kcSpliceType (HsSplice name hs_expr)
457 = setSrcSpan (getLoc hs_expr) $ do
459 ; case spliceOK level of {
460 Nothing -> failWithTc (illegalSplice level) ;
461 Just next_level -> do
464 Comp -> do { (t,k) <- kcTopSpliceType hs_expr
465 ; return (unLoc t, k) } ;
466 Brack _ ps_var lie_var -> do
468 { -- A splice inside brackets
469 ; meta_ty <- tcMetaTy typeQTyConName
470 ; expr' <- setStage (Splice next_level) $
472 tcMonoExpr hs_expr meta_ty
474 -- Write the pending splice into the bucket
475 ; ps <- readMutVar ps_var
476 ; writeMutVar ps_var ((name,expr') : ps)
478 -- e.g. [| Int -> $(h 4) |]
479 -- Here (h 4) :: Q Type
480 -- but $(h 4) :: forall a.a i.e. any kind
482 ; return (panic "kcSpliceType", kind) -- The returned type is ignored
484 ; Splice {} -> panic "kcSpliceType Splice"
487 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
489 = do { meta_ty <- tcMetaTy typeQTyConName
491 -- Typecheck the expression
492 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
494 -- Run the expression
495 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
496 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
498 ; traceTc (text "Got result" <+> ppr hs_ty2)
500 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
502 -- Rename it, but bale out if there are errors
503 -- otherwise the type checker just gives more spurious errors
504 ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
505 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
510 %************************************************************************
512 \subsection{Splicing an expression}
514 %************************************************************************
517 -- Always at top level
518 -- Type sig at top of file:
519 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
521 = do { meta_dec_ty <- tcMetaTy decTyConName
522 ; meta_q_ty <- tcMetaTy qTyConName
523 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
524 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
526 -- Run the expression
527 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
528 ; decls <- runMetaD convertToHsDecls zonked_q_expr
530 ; traceTc (text "Got result" <+> vcat (map ppr decls))
531 ; showSplice "declarations"
533 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
538 %************************************************************************
540 \subsection{Running an expression}
542 %************************************************************************
545 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
546 -> LHsExpr Id -- Of type (Q Exp)
547 -> TcM (LHsExpr RdrName)
550 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
551 -> LHsExpr Id -- Of type (Q Pat)
555 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
556 -> LHsExpr Id -- Of type (Q Type)
557 -> TcM (LHsType RdrName)
560 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
561 -> LHsExpr Id -- Of type Q [Dec]
562 -> TcM [LHsDecl RdrName]
565 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
566 -> LHsExpr Id -- Of type X
567 -> TcM hs_syn -- Of type t
570 ds_expr <- initDsTc (dsLExpr expr)
571 -- Compile and link it; might fail if linking fails
572 ; hsc_env <- getTopEnv
573 ; src_span <- getSrcSpanM
574 ; either_hval <- tryM $ liftIO $
575 HscMain.compileExpr hsc_env src_span ds_expr
576 ; case either_hval of {
577 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
580 { -- Coerce it to Q t, and run it
582 -- Running might fail if it throws an exception of any kind (hence tryAllM)
583 -- including, say, a pattern-match exception in the code we are running
585 -- We also do the TH -> HS syntax conversion inside the same
586 -- exception-cacthing thing so that if there are any lurking
587 -- exceptions in the data structure returned by hval, we'll
588 -- encounter them inside the try
590 -- See Note [Exceptions in TH]
591 let expr_span = getLoc expr
592 ; either_tval <- tryAllM $
593 setSrcSpan expr_span $ -- Set the span so that qLocation can
594 -- see where this splice is
595 do { th_syn <- TH.runQ (unsafeCoerce# hval)
596 ; case convert expr_span th_syn of
597 Left err -> failWithTc err
598 Right hs_syn -> return hs_syn }
600 ; case either_tval of
602 #if __GLASGOW_HASKELL__ < 609
603 Left exn | Just s <- Exception.userErrors exn
604 , s == "IOEnv failure"
605 -> failM -- Error already in Tc monad
606 | otherwise -> failWithTc (mk_msg "run" exn) -- Exception
608 Left (SomeException exn) ->
610 Just (ErrorCall "IOEnv failure") ->
611 failM -- Error already in Tc monad
616 (ioeGetErrorString ioe == "IOEnv failure") ->
617 failM -- Error already in Tc monad
618 _ -> failWithTc (mk_msg "run" exn) -- Exception
622 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
623 nest 2 (text (Panic.showException exn)),
624 nest 2 (text "Code:" <+> ppr expr)]
627 Note [Exceptions in TH]
628 ~~~~~~~~~~~~~~~~~~~~~~~
629 Supppose we have something like this
633 f n | n>3 = fail "Too many declarations"
636 The 'fail' is a user-generated failure, and should be displayed as a
637 perfectly ordinary compiler error message, not a panic or anything
638 like that. Here's how it's processed:
640 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
641 effectively transforms (fail s) to
642 qReport True s >> fail
643 where 'qReport' comes from the Quasi class and fail from its monad
646 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
647 (qReport True s) by using addErr to add an error message to the bag of errors.
648 The 'fail' in TcM raises a UserError, with the uninteresting string
651 * So, when running a splice, we catch all exceptions; then for
652 - a UserError "IOEnv failure", we assume the error is already
653 in the error-bag (above)
654 - other errors, we add an error to the bag
658 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
661 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
662 qNewName s = do { u <- newUnique
664 ; return (TH.mkNameU s i) }
666 qReport True msg = addErr (text msg)
667 qReport False msg = addReport (text msg)
669 qLocation = do { m <- getModule
671 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
672 , TH.loc_module = moduleNameString (moduleName m)
673 , TH.loc_package = packageIdString (modulePackageId m)
674 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
675 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
679 -- For qRecover, discard error messages if
680 -- the recovery action is chosen. Otherwise
681 -- we'll only fail higher up. c.f. tryTcLIE_
682 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
684 Just val -> do { addMessages msgs -- There might be warnings
686 Nothing -> recover -- Discard all msgs
689 qRunIO io = liftIO io
693 %************************************************************************
695 \subsection{Errors and contexts}
697 %************************************************************************
700 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
701 showSplice what before after = do
703 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
704 nest 2 (sep [nest 2 (ppr before),
708 illegalBracket :: ThStage -> SDoc
710 = ptext (sLit "Illegal bracket at level") <+> ppr level
712 illegalSplice :: ThStage -> SDoc
714 = ptext (sLit "Illegal splice at level") <+> ppr level
720 %************************************************************************
724 %************************************************************************
728 reify :: TH.Name -> TcM TH.Info
730 = do { name <- lookupThName th_name
731 ; thing <- tcLookupTh name
732 -- ToDo: this tcLookup could fail, which would give a
733 -- rather unhelpful error message
734 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
738 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
739 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
740 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
741 ppr_ns _ = panic "reify/ppr_ns"
743 lookupThName :: TH.Name -> TcM Name
744 lookupThName th_name@(TH.Name occ flavour)
745 = do { mb_ns <- mapM lookup [ thRdrName gns occ_str flavour
746 | gns <- guessed_nss]
747 ; case catMaybes mb_ns of
748 [] -> failWithTc (notInScope th_name)
749 (n:_) -> return n } -- Pick the first that works
750 -- E.g. reify (mkName "A") will pick the class A
751 -- in preference to the data constructor A
754 = do { -- Repeat much of lookupOccRn, becase we want
755 -- to report errors in a TH-relevant way
756 ; rdr_env <- getLocalRdrEnv
757 ; case lookupLocalRdrEnv rdr_env rdr_name of
758 Just name -> return (Just name)
759 Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
760 -> do { name <- lookupImportedName rdr_name
761 ; return (Just name) }
762 | otherwise -- Unqual, Qual
763 -> lookupSrcOcc_maybe rdr_name }
765 -- guessed_ns are the name spaces guessed from looking at the TH name
766 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
767 | otherwise = [OccName.varName, OccName.tvName]
768 occ_str = TH.occString occ
770 tcLookupTh :: Name -> TcM TcTyThing
771 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
772 -- it gives a reify-related error message on failure, whereas in the normal
773 -- tcLookup, failure is a bug.
775 = do { (gbl_env, lcl_env) <- getEnvs
776 ; case lookupNameEnv (tcl_env lcl_env) name of {
777 Just thing -> return thing;
779 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
780 then -- It's defined in this module
781 case lookupNameEnv (tcg_type_env gbl_env) name of
782 Just thing -> return (AGlobal thing)
783 Nothing -> failWithTc (notInEnv name)
785 else do -- It's imported
786 { (eps,hpt) <- getEpsAndHpt
788 ; case lookupType dflags hpt (eps_PTE eps) name of
789 Just thing -> return (AGlobal thing)
790 Nothing -> do { thing <- tcImportDecl name
791 ; return (AGlobal thing) }
792 -- Imported names should always be findable;
793 -- if not, we fail hard in tcImportDecl
796 notInScope :: TH.Name -> SDoc
797 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
798 ptext (sLit "is not in scope at a reify")
799 -- Ugh! Rather an indirect way to display the name
801 notInEnv :: Name -> SDoc
802 notInEnv name = quotes (ppr name) <+>
803 ptext (sLit "is not in the type environment at a reify")
805 ------------------------------
806 reifyThing :: TcTyThing -> TcM TH.Info
807 -- The only reason this is monadic is for error reporting,
808 -- which in turn is mainly for the case when TH can't express
809 -- some random GHC extension
811 reifyThing (AGlobal (AnId id))
812 = do { ty <- reifyType (idType id)
813 ; fix <- reifyFixity (idName id)
814 ; let v = reifyName id
815 ; case globalIdDetails id of
816 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
817 _ -> return (TH.VarI v ty Nothing fix)
820 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
821 reifyThing (AGlobal (AClass cls)) = reifyClass cls
822 reifyThing (AGlobal (ADataCon dc))
823 = do { let name = dataConName dc
824 ; ty <- reifyType (idType (dataConWrapId dc))
825 ; fix <- reifyFixity name
826 ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
828 reifyThing (ATcId {tct_id = id, tct_type = ty})
829 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
830 -- though it may be incomplete
831 ; ty2 <- reifyType ty1
832 ; fix <- reifyFixity (idName id)
833 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
835 reifyThing (ATyVar tv ty)
836 = do { ty1 <- zonkTcType ty
837 ; ty2 <- reifyType ty1
838 ; return (TH.TyVarI (reifyName tv) ty2) }
840 reifyThing (AThing {}) = panic "reifyThing AThing"
842 ------------------------------
843 reifyTyCon :: TyCon -> TcM TH.Info
845 | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
846 | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
848 = do { let (tvs, rhs) = synTyConDefn tc
849 ; rhs' <- reifyType rhs
850 ; return (TH.TyConI $
851 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
854 = do { cxt <- reifyCxt (tyConStupidTheta tc)
855 ; let tvs = tyConTyVars tc
856 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
857 ; let name = reifyName tc
858 r_tvs = reifyTyVars tvs
859 deriv = [] -- Don't know about deriving
860 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
861 | otherwise = TH.DataD cxt name r_tvs cons deriv
862 ; return (TH.TyConI decl) }
864 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
866 | isVanillaDataCon dc
867 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
868 ; let stricts = map reifyStrict (dataConStrictMarks dc)
869 fields = dataConFieldLabels dc
873 ; ASSERT( length arg_tys == length stricts )
874 if not (null fields) then
875 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
877 if dataConIsInfix dc then
878 ASSERT( length arg_tys == 2 )
879 return (TH.InfixC (s1,a1) name (s2,a2))
881 return (TH.NormalC name (stricts `zip` arg_tys)) }
883 = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:")
886 ------------------------------
887 reifyClass :: Class -> TcM TH.Info
889 = do { cxt <- reifyCxt theta
890 ; ops <- mapM reify_op op_stuff
891 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
893 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
894 fds' = map reifyFunDep fds
895 reify_op (op, _) = do { ty <- reifyType (idType op)
896 ; return (TH.SigD (reifyName op) ty) }
898 ------------------------------
899 reifyType :: TypeRep.Type -> TcM TH.Type
900 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
901 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
902 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
903 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
904 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
905 ; tau' <- reifyType tau
906 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
908 (tvs, cxt, tau) = tcSplitSigmaTy ty
909 reifyType (PredTy {}) = panic "reifyType PredTy"
911 reifyTypes :: [Type] -> TcM [TH.Type]
912 reifyTypes = mapM reifyType
913 reifyCxt :: [PredType] -> TcM [TH.Type]
914 reifyCxt = mapM reifyPred
916 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
917 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
919 reifyTyVars :: [TyVar] -> [TH.Name]
920 reifyTyVars = map reifyName
922 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
923 reify_tc_app tc tys = do { tys' <- reifyTypes tys
924 ; return (foldl TH.AppT (TH.ConT tc) tys') }
926 reifyPred :: TypeRep.PredType -> TcM TH.Type
927 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
928 reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
929 reifyPred (EqPred {}) = panic "reifyPred EqPred"
932 ------------------------------
933 reifyName :: NamedThing n => n -> TH.Name
935 | isExternalName name = mk_varg pkg_str mod_str occ_str
936 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
937 -- Many of the things we reify have local bindings, and
938 -- NameL's aren't supposed to appear in binding positions, so
939 -- we use NameU. When/if we start to reify nested things, that
940 -- have free variables, we may need to generate NameL's for them.
943 mod = nameModule name
944 pkg_str = packageIdString (modulePackageId mod)
945 mod_str = moduleNameString (moduleName mod)
946 occ_str = occNameString occ
947 occ = nameOccName name
948 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
949 | OccName.isVarOcc occ = TH.mkNameG_v
950 | OccName.isTcOcc occ = TH.mkNameG_tc
951 | otherwise = pprPanic "reifyName" (ppr name)
953 ------------------------------
954 reifyFixity :: Name -> TcM TH.Fixity
956 = do { fix <- lookupFixityRn name
957 ; return (conv_fix fix) }
959 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
960 conv_dir BasicTypes.InfixR = TH.InfixR
961 conv_dir BasicTypes.InfixL = TH.InfixL
962 conv_dir BasicTypes.InfixN = TH.InfixN
964 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
965 reifyStrict MarkedStrict = TH.IsStrict
966 reifyStrict MarkedUnboxed = TH.IsStrict
967 reifyStrict NotMarkedStrict = TH.NotStrict
969 ------------------------------
970 noTH :: LitString -> SDoc -> TcM a
971 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
972 ptext (sLit "in Template Haskell:"),