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 )
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 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
165 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
166 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
167 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
168 -- None of these functions add constraints to the LIE
170 runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
171 runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
174 tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
175 tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
176 tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
177 kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
179 runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
180 runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
184 %************************************************************************
186 \subsection{Quoting an expression}
188 %************************************************************************
190 Note [Handling brackets]
191 ~~~~~~~~~~~~~~~~~~~~~~~~
192 Source: f = [| Just $(g 3) |]
193 The [| |] part is a HsBracket
195 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
196 The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
197 The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
199 Desugared: f = do { s7 <- g Int 3
200 ; return (ConE "Data.Maybe.Just" s7) }
203 tcBracket brack res_ty = do
205 case bracketOK level of {
206 Nothing -> failWithTc (illegalBracket level) ;
207 Just next_level -> do
209 -- Typecheck expr to make sure it is valid,
210 -- but throw away the results. We'll type check
211 -- it again when we actually use it.
213 pending_splices <- newMutVar []
216 (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
217 (getLIE (tc_bracket next_level brack))
218 tcSimplifyBracket lie
220 -- Make the expected type have the right shape
221 boxyUnify meta_ty res_ty
223 -- Return the original expression, not the type-decorated one
224 pendings <- readMutVar pending_splices
225 return (noLoc (HsBracketOut brack pendings))
228 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
229 tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
230 = do { thing <- tcLookup name
232 AGlobal _ -> return ()
233 ATcId { tct_level = bind_lvl, tct_id = id }
234 | thTopLevelId id -- C.f thTopLevelId case of
235 -> keepAliveTc id -- TcExpr.thBrackId
237 -> do { checkTc (use_lvl == bind_lvl)
238 (quotedNameStageErr name) }
239 _ -> pprPanic "th_bracket" (ppr name)
241 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
244 tc_bracket _ (ExpBr expr)
245 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
246 ; tcMonoExpr expr any_ty
247 ; tcMetaTy expQTyConName }
248 -- Result type is Expr (= Q Exp)
250 tc_bracket _ (TypBr typ)
251 = do { tcHsSigType ExprSigCtxt typ
252 ; tcMetaTy typeQTyConName }
253 -- Result type is Type (= Q Typ)
255 tc_bracket _ (DecBr decls)
256 = do { tcTopSrcDecls emptyModDetails decls
257 -- Typecheck the declarations, dicarding the result
258 -- We'll get all that stuff later, when we splice it in
260 ; decl_ty <- tcMetaTy decTyConName
261 ; q_ty <- tcMetaTy qTyConName
262 ; return (mkAppTy q_ty (mkListTy decl_ty))
263 -- Result type is Q [Dec]
266 tc_bracket _ (PatBr _)
267 = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
269 quotedNameStageErr :: Name -> SDoc
271 = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
272 , ptext (sLit "must be used at the same stage at which is is bound")]
276 %************************************************************************
278 \subsection{Splicing an expression}
280 %************************************************************************
283 tcSpliceExpr (HsSplice name expr) res_ty
284 = setSrcSpan (getLoc expr) $ do
286 case spliceOK level of {
287 Nothing -> failWithTc (illegalSplice level) ;
291 Comp -> do { e <- tcTopSplice expr res_ty
292 ; return (unLoc e) } ;
293 Brack _ ps_var lie_var -> do
295 -- A splice inside brackets
296 -- NB: ignore res_ty, apart from zapping it to a mono-type
297 -- e.g. [| reverse $(h 4) |]
298 -- Here (h 4) :: Q Exp
299 -- but $(h 4) :: forall a.a i.e. anything!
302 meta_exp_ty <- tcMetaTy expQTyConName
303 expr' <- setStage (Splice next_level) (
305 tcMonoExpr expr meta_exp_ty
308 -- Write the pending splice into the bucket
309 ps <- readMutVar ps_var
310 writeMutVar ps_var ((name,expr') : ps)
312 return (panic "tcSpliceExpr") -- The returned expression is ignored
314 ; Splice {} -> panic "tcSpliceExpr Splice"
317 -- tcTopSplice used to have this:
318 -- Note that we do not decrement the level (to -1) before
319 -- typechecking the expression. For example:
320 -- f x = $( ...$(g 3) ... )
321 -- The recursive call to tcMonoExpr will simply expand the
322 -- inner escape before dealing with the outer one
324 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
325 tcTopSplice expr res_ty = do
326 meta_exp_ty <- tcMetaTy expQTyConName
328 -- Typecheck the expression
329 zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
331 -- Run the expression
332 traceTc (text "About to run" <+> ppr zonked_q_expr)
333 expr2 <- runMetaE convertToHsExpr zonked_q_expr
335 traceTc (text "Got result" <+> ppr expr2)
337 showSplice "expression"
338 zonked_q_expr (ppr expr2)
340 -- Rename it, but bale out if there are errors
341 -- otherwise the type checker just gives more spurious errors
342 (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
344 tcMonoExpr exp3 res_ty
347 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
348 -- Type check an expression that is the body of a top-level splice
349 -- (the caller will compile and run it)
350 tcTopSpliceExpr expr meta_ty
351 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
352 -- if the type checker fails!
354 setStage topSpliceStage $ do
357 do { recordThUse -- Record that TH is used (for pkg depdendency)
359 -- Typecheck the expression
360 ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
362 -- Solve the constraints
363 ; const_binds <- tcSimplifyTop lie
366 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
370 %************************************************************************
374 %************************************************************************
376 Note [Quasi-quote overview]
377 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
378 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
379 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
384 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
385 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
386 defined in another module, because we are going to run it here. It's
387 a bit like a TH splice:
390 However, you can do this in patterns as well as terms. Becuase of this,
391 the splice is run by the *renamer* rather than the type checker.
394 runQuasiQuote :: Outputable hs_syn
395 => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String
396 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
397 -> String -- Documentation string only
398 -> Name -- Name of th_syn type
399 -> (SrcSpan -> th_syn -> Either Message hs_syn)
401 runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
402 = do { -- Check that the quoter is not locally defined, otherwise the TH
403 -- machinery will not be able to run the quasiquote.
404 ; this_mod <- getModule
405 ; let is_local = case nameModule_maybe quoter of
406 Just mod | mod == this_mod -> True
409 ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
410 ; checkTc (not is_local) (quoteStageError quoter)
412 -- Build the expression
413 ; let quoterExpr = L q_span $! HsVar $! quoter
414 ; let quoteExpr = L q_span $! HsLit $! HsString quote
415 ; let expr = L q_span $
417 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
419 ; meta_exp_ty <- tcMetaTy meta_ty
421 -- Typecheck the expression
422 ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
424 -- Run the expression
425 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
426 ; result <- runMeta convert zonked_q_expr
427 ; traceTc (text "Got result" <+> ppr result)
428 ; showSplice desc zonked_q_expr (ppr result)
432 runQuasiQuoteExpr quasiquote
433 = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr
435 runQuasiQuotePat quasiquote
436 = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
438 quoteStageError :: Name -> SDoc
439 quoteStageError quoter
440 = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
441 nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
445 %************************************************************************
449 %************************************************************************
451 Very like splicing an expression, but we don't yet share code.
454 kcSpliceType (HsSplice name hs_expr)
455 = setSrcSpan (getLoc hs_expr) $ do
457 ; case spliceOK level of {
458 Nothing -> failWithTc (illegalSplice level) ;
459 Just next_level -> do
462 Comp -> do { (t,k) <- kcTopSpliceType hs_expr
463 ; return (unLoc t, k) } ;
464 Brack _ ps_var lie_var -> do
466 { -- A splice inside brackets
467 ; meta_ty <- tcMetaTy typeQTyConName
468 ; expr' <- setStage (Splice next_level) $
470 tcMonoExpr hs_expr meta_ty
472 -- Write the pending splice into the bucket
473 ; ps <- readMutVar ps_var
474 ; writeMutVar ps_var ((name,expr') : ps)
476 -- e.g. [| Int -> $(h 4) |]
477 -- Here (h 4) :: Q Type
478 -- but $(h 4) :: forall a.a i.e. any kind
480 ; return (panic "kcSpliceType", kind) -- The returned type is ignored
482 ; Splice {} -> panic "kcSpliceType Splice"
485 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
487 = do { meta_ty <- tcMetaTy typeQTyConName
489 -- Typecheck the expression
490 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
492 -- Run the expression
493 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
494 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
496 ; traceTc (text "Got result" <+> ppr hs_ty2)
498 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
500 -- Rename it, but bale out if there are errors
501 -- otherwise the type checker just gives more spurious errors
502 ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
503 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
508 %************************************************************************
510 \subsection{Splicing an expression}
512 %************************************************************************
515 -- Always at top level
516 -- Type sig at top of file:
517 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
519 = do { meta_dec_ty <- tcMetaTy decTyConName
520 ; meta_q_ty <- tcMetaTy qTyConName
521 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
522 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
524 -- Run the expression
525 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
526 ; decls <- runMetaD convertToHsDecls zonked_q_expr
528 ; traceTc (text "Got result" <+> vcat (map ppr decls))
529 ; showSplice "declarations"
531 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
536 %************************************************************************
538 \subsection{Running an expression}
540 %************************************************************************
543 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
544 -> LHsExpr Id -- Of type (Q Exp)
545 -> TcM (LHsExpr RdrName)
548 runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
549 -> LHsExpr Id -- Of type (Q Pat)
553 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
554 -> LHsExpr Id -- Of type (Q Type)
555 -> TcM (LHsType RdrName)
558 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
559 -> LHsExpr Id -- Of type Q [Dec]
560 -> TcM [LHsDecl RdrName]
563 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
564 -> LHsExpr Id -- Of type X
565 -> TcM hs_syn -- Of type t
568 ds_expr <- initDsTc (dsLExpr expr)
569 -- Compile and link it; might fail if linking fails
570 ; hsc_env <- getTopEnv
571 ; src_span <- getSrcSpanM
572 ; either_hval <- tryM $ liftIO $
573 HscMain.compileExpr hsc_env src_span ds_expr
574 ; case either_hval of {
575 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
578 { -- Coerce it to Q t, and run it
580 -- Running might fail if it throws an exception of any kind (hence tryAllM)
581 -- including, say, a pattern-match exception in the code we are running
583 -- We also do the TH -> HS syntax conversion inside the same
584 -- exception-cacthing thing so that if there are any lurking
585 -- exceptions in the data structure returned by hval, we'll
586 -- encounter them inside the try
588 -- See Note [Exceptions in TH]
589 let expr_span = getLoc expr
590 ; either_tval <- tryAllM $
591 setSrcSpan expr_span $ -- Set the span so that qLocation can
592 -- see where this splice is
593 do { th_syn <- TH.runQ (unsafeCoerce# hval)
594 ; case convert expr_span th_syn of
595 Left err -> failWithTc err
596 Right hs_syn -> return hs_syn }
598 ; case either_tval of
600 #if __GLASGOW_HASKELL__ < 609
601 Left exn | Just s <- Exception.userErrors exn
602 , s == "IOEnv failure"
603 -> failM -- Error already in Tc monad
604 | otherwise -> failWithTc (mk_msg "run" exn) -- Exception
606 Left (SomeException exn) -> do
608 Just (ErrorCall "IOEnv failure") ->
609 failM -- Error already in Tc monad
610 _ -> failWithTc (mk_msg "run" exn) -- Exception
614 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
615 nest 2 (text (Panic.showException exn)),
616 nest 2 (text "Code:" <+> ppr expr)]
619 Note [Exceptions in TH]
620 ~~~~~~~~~~~~~~~~~~~~~~~
621 Supppose we have something like this
625 f n | n>3 = fail "Too many declarations"
628 The 'fail' is a user-generated failure, and should be displayed as a
629 perfectly ordinary compiler error message, not a panic or anything
630 like that. Here's how it's processed:
632 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
633 effectively transforms (fail s) to
634 qReport True s >> fail
635 where 'qReport' comes from the Quasi class and fail from its monad
638 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
639 (qReport True s) by using addErr to add an error message to the bag of errors.
640 The 'fail' in TcM raises a UserError, with the uninteresting string
643 * So, when running a splice, we catch all exceptions; then for
644 - a UserError "IOEnv failure", we assume the error is already
645 in the error-bag (above)
646 - other errors, we add an error to the bag
650 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
653 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
654 qNewName s = do { u <- newUnique
656 ; return (TH.mkNameU s i) }
658 qReport True msg = addErr (text msg)
659 qReport False msg = addReport (text msg)
661 qLocation = do { m <- getModule
663 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
664 , TH.loc_module = moduleNameString (moduleName m)
665 , TH.loc_package = packageIdString (modulePackageId m)
666 , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
667 , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
671 -- For qRecover, discard error messages if
672 -- the recovery action is chosen. Otherwise
673 -- we'll only fail higher up. c.f. tryTcLIE_
674 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
676 Just val -> do { addMessages msgs -- There might be warnings
678 Nothing -> recover -- Discard all msgs
681 qRunIO io = liftIO io
685 %************************************************************************
687 \subsection{Errors and contexts}
689 %************************************************************************
692 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
693 showSplice what before after = do
695 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
696 nest 2 (sep [nest 2 (ppr before),
700 illegalBracket :: ThStage -> SDoc
702 = ptext (sLit "Illegal bracket at level") <+> ppr level
704 illegalSplice :: ThStage -> SDoc
706 = ptext (sLit "Illegal splice at level") <+> ppr level
712 %************************************************************************
716 %************************************************************************
720 reify :: TH.Name -> TcM TH.Info
722 = do { name <- lookupThName th_name
723 ; thing <- tcLookupTh name
724 -- ToDo: this tcLookup could fail, which would give a
725 -- rather unhelpful error message
726 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
730 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
731 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
732 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
733 ppr_ns _ = panic "reify/ppr_ns"
735 lookupThName :: TH.Name -> TcM Name
736 lookupThName th_name@(TH.Name occ flavour)
737 = do { mb_ns <- mapM lookup [ thRdrName gns occ_str flavour
738 | gns <- guessed_nss]
739 ; case catMaybes mb_ns of
740 [] -> failWithTc (notInScope th_name)
741 (n:_) -> return n } -- Pick the first that works
742 -- E.g. reify (mkName "A") will pick the class A
743 -- in preference to the data constructor A
746 = do { -- Repeat much of lookupOccRn, becase we want
747 -- to report errors in a TH-relevant way
748 ; rdr_env <- getLocalRdrEnv
749 ; case lookupLocalRdrEnv rdr_env rdr_name of
750 Just name -> return (Just name)
751 Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
752 -> do { name <- lookupImportedName rdr_name
753 ; return (Just name) }
754 | otherwise -- Unqual, Qual
755 -> lookupSrcOcc_maybe rdr_name }
757 -- guessed_ns are the name spaces guessed from looking at the TH name
758 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
759 | otherwise = [OccName.varName, OccName.tvName]
760 occ_str = TH.occString occ
762 tcLookupTh :: Name -> TcM TcTyThing
763 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
764 -- it gives a reify-related error message on failure, whereas in the normal
765 -- tcLookup, failure is a bug.
767 = do { (gbl_env, lcl_env) <- getEnvs
768 ; case lookupNameEnv (tcl_env lcl_env) name of {
769 Just thing -> return thing;
771 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
772 then -- It's defined in this module
773 case lookupNameEnv (tcg_type_env gbl_env) name of
774 Just thing -> return (AGlobal thing)
775 Nothing -> failWithTc (notInEnv name)
777 else do -- It's imported
778 { (eps,hpt) <- getEpsAndHpt
780 ; case lookupType dflags hpt (eps_PTE eps) name of
781 Just thing -> return (AGlobal thing)
782 Nothing -> do { thing <- tcImportDecl name
783 ; return (AGlobal thing) }
784 -- Imported names should always be findable;
785 -- if not, we fail hard in tcImportDecl
788 notInScope :: TH.Name -> SDoc
789 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
790 ptext (sLit "is not in scope at a reify")
791 -- Ugh! Rather an indirect way to display the name
793 notInEnv :: Name -> SDoc
794 notInEnv name = quotes (ppr name) <+>
795 ptext (sLit "is not in the type environment at a reify")
797 ------------------------------
798 reifyThing :: TcTyThing -> TcM TH.Info
799 -- The only reason this is monadic is for error reporting,
800 -- which in turn is mainly for the case when TH can't express
801 -- some random GHC extension
803 reifyThing (AGlobal (AnId id))
804 = do { ty <- reifyType (idType id)
805 ; fix <- reifyFixity (idName id)
806 ; let v = reifyName id
807 ; case globalIdDetails id of
808 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
809 _ -> return (TH.VarI v ty Nothing fix)
812 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
813 reifyThing (AGlobal (AClass cls)) = reifyClass cls
814 reifyThing (AGlobal (ADataCon dc))
815 = do { let name = dataConName dc
816 ; ty <- reifyType (idType (dataConWrapId dc))
817 ; fix <- reifyFixity name
818 ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
820 reifyThing (ATcId {tct_id = id, tct_type = ty})
821 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
822 -- though it may be incomplete
823 ; ty2 <- reifyType ty1
824 ; fix <- reifyFixity (idName id)
825 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
827 reifyThing (ATyVar tv ty)
828 = do { ty1 <- zonkTcType ty
829 ; ty2 <- reifyType ty1
830 ; return (TH.TyVarI (reifyName tv) ty2) }
832 reifyThing (AThing {}) = panic "reifyThing AThing"
834 ------------------------------
835 reifyTyCon :: TyCon -> TcM TH.Info
837 | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
838 | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
840 = do { let (tvs, rhs) = synTyConDefn tc
841 ; rhs' <- reifyType rhs
842 ; return (TH.TyConI $
843 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
846 = do { cxt <- reifyCxt (tyConStupidTheta tc)
847 ; let tvs = tyConTyVars tc
848 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
849 ; let name = reifyName tc
850 r_tvs = reifyTyVars tvs
851 deriv = [] -- Don't know about deriving
852 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
853 | otherwise = TH.DataD cxt name r_tvs cons deriv
854 ; return (TH.TyConI decl) }
856 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
858 | isVanillaDataCon dc
859 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
860 ; let stricts = map reifyStrict (dataConStrictMarks dc)
861 fields = dataConFieldLabels dc
865 ; ASSERT( length arg_tys == length stricts )
866 if not (null fields) then
867 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
869 if dataConIsInfix dc then
870 ASSERT( length arg_tys == 2 )
871 return (TH.InfixC (s1,a1) name (s2,a2))
873 return (TH.NormalC name (stricts `zip` arg_tys)) }
875 = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:")
878 ------------------------------
879 reifyClass :: Class -> TcM TH.Info
881 = do { cxt <- reifyCxt theta
882 ; ops <- mapM reify_op op_stuff
883 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
885 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
886 fds' = map reifyFunDep fds
887 reify_op (op, _) = do { ty <- reifyType (idType op)
888 ; return (TH.SigD (reifyName op) ty) }
890 ------------------------------
891 reifyType :: TypeRep.Type -> TcM TH.Type
892 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
893 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
894 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
895 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
896 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
897 ; tau' <- reifyType tau
898 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
900 (tvs, cxt, tau) = tcSplitSigmaTy ty
901 reifyType (PredTy {}) = panic "reifyType PredTy"
903 reifyTypes :: [Type] -> TcM [TH.Type]
904 reifyTypes = mapM reifyType
905 reifyCxt :: [PredType] -> TcM [TH.Type]
906 reifyCxt = mapM reifyPred
908 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
909 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
911 reifyTyVars :: [TyVar] -> [TH.Name]
912 reifyTyVars = map reifyName
914 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
915 reify_tc_app tc tys = do { tys' <- reifyTypes tys
916 ; return (foldl TH.AppT (TH.ConT tc) tys') }
918 reifyPred :: TypeRep.PredType -> TcM TH.Type
919 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
920 reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
921 reifyPred (EqPred {}) = panic "reifyPred EqPred"
924 ------------------------------
925 reifyName :: NamedThing n => n -> TH.Name
927 | isExternalName name = mk_varg pkg_str mod_str occ_str
928 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
929 -- Many of the things we reify have local bindings, and
930 -- NameL's aren't supposed to appear in binding positions, so
931 -- we use NameU. When/if we start to reify nested things, that
932 -- have free variables, we may need to generate NameL's for them.
935 mod = nameModule name
936 pkg_str = packageIdString (modulePackageId mod)
937 mod_str = moduleNameString (moduleName mod)
938 occ_str = occNameString occ
939 occ = nameOccName name
940 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
941 | OccName.isVarOcc occ = TH.mkNameG_v
942 | OccName.isTcOcc occ = TH.mkNameG_tc
943 | otherwise = pprPanic "reifyName" (ppr name)
945 ------------------------------
946 reifyFixity :: Name -> TcM TH.Fixity
948 = do { fix <- lookupFixityRn name
949 ; return (conv_fix fix) }
951 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
952 conv_dir BasicTypes.InfixR = TH.InfixR
953 conv_dir BasicTypes.InfixL = TH.InfixL
954 conv_dir BasicTypes.InfixN = TH.InfixN
956 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
957 reifyStrict MarkedStrict = TH.IsStrict
958 reifyStrict MarkedUnboxed = TH.IsStrict
959 reifyStrict NotMarkedStrict = TH.NotStrict
961 ------------------------------
962 noTH :: LitString -> SDoc -> TcM a
963 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
964 ptext (sLit "in Template Haskell:"),