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 ) where
18 #include "HsVersions.h"
22 -- These imports are the reason that TcSplice
23 -- is very high up the module hierarchy
57 import DsMonad hiding (Splice)
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 import Control.Monad ( liftM )
75 import qualified Control.Exception as Exception( userErrors )
78 Note [Template Haskell levels]
79 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
80 * Imported things are impLevel (= 0)
81 * Variables are bound at the "current level"
82 * The current level starts off at topLevel (= 1)
83 * The level is decremented by splicing $(..)
84 incremented by brackets [| |]
85 incremented by name-quoting 'f
87 When a variable is used, we compare
88 bind: binding level, and
89 use: current level at usage site
92 bind > use Always error (bound later than used)
95 bind = use Always OK (bound same stage as used)
96 [| \x -> $(f [| x |]) |]
98 bind < use Inside brackets, it depends
102 For (bind < use) inside brackets, there are three cases:
103 - Imported things OK f = [| map |]
104 - Top-level things OK g = [| f |]
105 - Non-top-level Only if there is a liftable instance
106 h = \(x:Int) -> [| x |]
110 A quoted name is a bit like a quoted expression, except that we have no
111 cross-stage lifting (c.f. TcExpr.thBrackId).
115 f 'map -- OK; also for top-level defns of this module
117 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
118 -- cross-stage lifting
120 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
122 [| \x. $(f 'x) |] -- OK
126 %************************************************************************
128 \subsection{Main interface + stubs for the non-GHCI case
130 %************************************************************************
133 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
134 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
135 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
136 -- None of these functions add constraints to the LIE
139 tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
140 tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
144 %************************************************************************
146 \subsection{Quoting an expression}
148 %************************************************************************
150 Note [Handling brackets]
151 ~~~~~~~~~~~~~~~~~~~~~~~~
152 Source: f = [| Just $(g 3) |]
153 The [| |] part is a HsBracket
155 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
156 The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
157 The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
159 Desugared: f = do { s7 <- g Int 3
160 ; return (ConE "Data.Maybe.Just" s7) }
163 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
164 tcBracket brack res_ty
165 = getStage `thenM` \ level ->
166 case bracketOK level of {
167 Nothing -> failWithTc (illegalBracket level) ;
170 -- Typecheck expr to make sure it is valid,
171 -- but throw away the results. We'll type check
172 -- it again when we actually use it.
174 newMutVar [] `thenM` \ pending_splices ->
175 getLIEVar `thenM` \ lie_var ->
177 setStage (Brack next_level pending_splices lie_var) (
178 getLIE (tc_bracket brack)
179 ) `thenM` \ (meta_ty, lie) ->
180 tcSimplifyBracket lie `thenM_`
182 -- Make the expected type have the right shape
183 boxyUnify meta_ty res_ty `thenM_`
185 -- Return the original expression, not the type-decorated one
186 readMutVar pending_splices `thenM` \ pendings ->
187 returnM (noLoc (HsBracketOut brack pendings))
190 tc_bracket :: HsBracket Name -> TcM TcType
191 tc_bracket (VarBr name) -- Note [Quoting names]
192 = do { thing <- tcLookup name
194 AGlobal _ -> return ()
195 ATcId { tct_level = bind_lvl }
196 | isExternalName name -- C.f isExternalName case of
197 -> keepAliveTc name -- TcExpr.thBrackId
199 -> do { use_stage <- getStage
200 ; checkTc (thLevel use_stage == bind_lvl)
201 (quotedNameStageErr name) }
202 other -> pprPanic "th_bracket" (ppr name)
204 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
207 tc_bracket (ExpBr expr)
208 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
209 ; tcMonoExpr expr any_ty
210 ; tcMetaTy expQTyConName }
211 -- Result type is Expr (= Q Exp)
213 tc_bracket (TypBr typ)
214 = do { tcHsSigType ExprSigCtxt typ
215 ; tcMetaTy typeQTyConName }
216 -- Result type is Type (= Q Typ)
218 tc_bracket (DecBr decls)
219 = do { tcTopSrcDecls emptyModDetails decls
220 -- Typecheck the declarations, dicarding the result
221 -- We'll get all that stuff later, when we splice it in
223 ; decl_ty <- tcMetaTy decTyConName
224 ; q_ty <- tcMetaTy qTyConName
225 ; return (mkAppTy q_ty (mkListTy decl_ty))
226 -- Result type is Q [Dec]
230 = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet"))
233 = sep [ ptext SLIT("Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
234 , ptext SLIT("must be used at the same stage at which is is bound")]
238 %************************************************************************
240 \subsection{Splicing an expression}
242 %************************************************************************
245 tcSpliceExpr (HsSplice name expr) res_ty
246 = setSrcSpan (getLoc expr) $
247 getStage `thenM` \ level ->
248 case spliceOK level of {
249 Nothing -> failWithTc (illegalSplice level) ;
253 Comp -> do { e <- tcTopSplice expr res_ty
254 ; returnM (unLoc e) } ;
255 Brack _ ps_var lie_var ->
257 -- A splice inside brackets
258 -- NB: ignore res_ty, apart from zapping it to a mono-type
259 -- e.g. [| reverse $(h 4) |]
260 -- Here (h 4) :: Q Exp
261 -- but $(h 4) :: forall a.a i.e. anything!
263 unBox res_ty `thenM_`
264 tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
265 setStage (Splice next_level) (
267 tcMonoExpr expr meta_exp_ty
270 -- Write the pending splice into the bucket
271 readMutVar ps_var `thenM` \ ps ->
272 writeMutVar ps_var ((name,expr') : ps) `thenM_`
274 returnM (panic "tcSpliceExpr") -- The returned expression is ignored
277 -- tcTopSplice used to have this:
278 -- Note that we do not decrement the level (to -1) before
279 -- typechecking the expression. For example:
280 -- f x = $( ...$(g 3) ... )
281 -- The recursive call to tcMonoExpr will simply expand the
282 -- inner escape before dealing with the outer one
284 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
285 tcTopSplice expr res_ty
286 = tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
288 -- Typecheck the expression
289 tcTopSpliceExpr expr meta_exp_ty `thenM` \ zonked_q_expr ->
291 -- Run the expression
292 traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
293 runMetaE convertToHsExpr zonked_q_expr `thenM` \ expr2 ->
295 traceTc (text "Got result" <+> ppr expr2) `thenM_`
297 showSplice "expression"
298 zonked_q_expr (ppr expr2) `thenM_`
300 -- Rename it, but bale out if there are errors
301 -- otherwise the type checker just gives more spurious errors
302 checkNoErrs (rnLExpr expr2) `thenM` \ (exp3, fvs) ->
304 tcMonoExpr exp3 res_ty
307 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
308 -- Type check an expression that is the body of a top-level splice
309 -- (the caller will compile and run it)
310 tcTopSpliceExpr expr meta_ty
311 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
312 -- if the type checker fails!
314 setStage topSpliceStage $ do
317 do { recordThUse -- Record that TH is used (for pkg depdendency)
319 -- Typecheck the expression
320 ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
322 -- Solve the constraints
323 ; const_binds <- tcSimplifyTop lie
326 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
330 %************************************************************************
334 %************************************************************************
336 Very like splicing an expression, but we don't yet share code.
339 kcSpliceType (HsSplice name hs_expr)
340 = setSrcSpan (getLoc hs_expr) $ do
342 ; case spliceOK level of {
343 Nothing -> failWithTc (illegalSplice level) ;
344 Just next_level -> do
347 Comp -> do { (t,k) <- kcTopSpliceType hs_expr
348 ; return (unLoc t, k) } ;
349 Brack _ ps_var lie_var -> do
351 { -- A splice inside brackets
352 ; meta_ty <- tcMetaTy typeQTyConName
353 ; expr' <- setStage (Splice next_level) $
355 tcMonoExpr hs_expr meta_ty
357 -- Write the pending splice into the bucket
358 ; ps <- readMutVar ps_var
359 ; writeMutVar ps_var ((name,expr') : ps)
361 -- e.g. [| Int -> $(h 4) |]
362 -- Here (h 4) :: Q Type
363 -- but $(h 4) :: forall a.a i.e. any kind
365 ; returnM (panic "kcSpliceType", kind) -- The returned type is ignored
368 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
370 = do { meta_ty <- tcMetaTy typeQTyConName
372 -- Typecheck the expression
373 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
375 -- Run the expression
376 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
377 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
379 ; traceTc (text "Got result" <+> ppr hs_ty2)
381 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
383 -- Rename it, but bale out if there are errors
384 -- otherwise the type checker just gives more spurious errors
385 ; let doc = ptext SLIT("In the spliced type") <+> ppr hs_ty2
386 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
391 %************************************************************************
393 \subsection{Splicing an expression}
395 %************************************************************************
398 -- Always at top level
399 -- Type sig at top of file:
400 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
402 = do { meta_dec_ty <- tcMetaTy decTyConName
403 ; meta_q_ty <- tcMetaTy qTyConName
404 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
405 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
407 -- Run the expression
408 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
409 ; decls <- runMetaD convertToHsDecls zonked_q_expr
411 ; traceTc (text "Got result" <+> vcat (map ppr decls))
412 ; showSplice "declarations"
414 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
417 where handleErrors :: [Either a Message] -> TcM [a]
418 handleErrors [] = return []
419 handleErrors (Left x:xs) = liftM (x:) (handleErrors xs)
420 handleErrors (Right m:xs) = do addErrTc m
425 %************************************************************************
427 \subsection{Running an expression}
429 %************************************************************************
432 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
433 -> LHsExpr Id -- Of type (Q Exp)
434 -> TcM (LHsExpr RdrName)
437 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
438 -> LHsExpr Id -- Of type (Q Type)
439 -> TcM (LHsType RdrName)
442 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
443 -> LHsExpr Id -- Of type Q [Dec]
444 -> TcM [LHsDecl RdrName]
447 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
448 -> LHsExpr Id -- Of type X
449 -> TcM hs_syn -- Of type t
452 ds_expr <- initDsTc (dsLExpr expr)
453 -- Compile and link it; might fail if linking fails
454 ; hsc_env <- getTopEnv
455 ; src_span <- getSrcSpanM
456 ; either_hval <- tryM $ ioToTcRn $
457 HscMain.compileExpr hsc_env src_span ds_expr
458 ; case either_hval of {
459 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
462 { -- Coerce it to Q t, and run it
464 -- Running might fail if it throws an exception of any kind (hence tryAllM)
465 -- including, say, a pattern-match exception in the code we are running
467 -- We also do the TH -> HS syntax conversion inside the same
468 -- exception-cacthing thing so that if there are any lurking
469 -- exceptions in the data structure returned by hval, we'll
470 -- encounter them inside the try
472 -- See Note [Exceptions in TH]
473 either_tval <- tryAllM $ do
474 { th_syn <- TH.runQ (unsafeCoerce# hval)
475 ; case convert (getLoc expr) th_syn of
476 Left err -> failWithTc err
477 Right hs_syn -> return hs_syn }
479 ; case either_tval of
481 Left exn | Just s <- Exception.userErrors exn
482 , s == "IOEnv failure"
483 -> failM -- Error already in Tc monad
484 | otherwise -> failWithTc (mk_msg "run" exn) -- Exception
487 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
488 nest 2 (text (Panic.showException exn)),
489 nest 2 (text "Code:" <+> ppr expr)]
492 Note [Exceptions in TH]
493 ~~~~~~~~~~~~~~~~~~~~~~~
494 Supppose we have something like this
498 f n | n>3 = fail "Too many declarations"
501 The 'fail' is a user-generated failure, and should be displayed as a
502 perfectly ordinary compiler error message, not a panic or anything
503 like that. Here's how it's processed:
505 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
506 effectively transforms (fail s) to
507 qReport True s >> fail
508 where 'qReport' comes from the Quasi class and fail from its monad
511 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
512 (qReport True s) by using addErr to add an error message to the bag of errors.
513 The 'fail' in TcM raises a UserError, with the uninteresting string
516 * So, when running a splice, we catch all exceptions; then for
517 - a UserError "IOEnv failure", we assume the error is already
518 in the error-bag (above)
519 - other errors, we add an error to the bag
523 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
526 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
527 qNewName s = do { u <- newUnique
529 ; return (TH.mkNameU s i) }
531 qReport True msg = addErr (text msg)
532 qReport False msg = addReport (text msg)
534 qCurrentModule = do { m <- getModule;
535 return (moduleNameString (moduleName m)) }
536 -- ToDo: is throwing away the package name ok here?
540 -- For qRecover, discard error messages if
541 -- the recovery action is chosen. Otherwise
542 -- we'll only fail higher up. c.f. tryTcLIE_
543 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
545 Just val -> do { addMessages msgs -- There might be warnings
547 Nothing -> recover -- Discard all msgs
550 qRunIO io = ioToTcRn io
554 %************************************************************************
556 \subsection{Errors and contexts}
558 %************************************************************************
561 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
562 showSplice what before after
563 = getSrcSpanM `thenM` \ loc ->
564 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
565 nest 2 (sep [nest 2 (ppr before),
570 = ptext SLIT("Illegal bracket at level") <+> ppr level
573 = ptext SLIT("Illegal splice at level") <+> ppr level
579 %************************************************************************
583 %************************************************************************
587 reify :: TH.Name -> TcM TH.Info
589 = do { name <- lookupThName th_name
590 ; thing <- tcLookupTh name
591 -- ToDo: this tcLookup could fail, which would give a
592 -- rather unhelpful error message
593 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
597 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
598 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
599 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
601 lookupThName :: TH.Name -> TcM Name
602 lookupThName th_name@(TH.Name occ flavour)
603 = do { let rdr_name = thRdrName guessed_ns occ_str flavour
605 -- Repeat much of lookupOccRn, becase we want
606 -- to report errors in a TH-relevant way
607 ; rdr_env <- getLocalRdrEnv
608 ; case lookupLocalRdrEnv rdr_env rdr_name of
609 Just name -> return name
610 Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
611 -> lookupImportedName rdr_name
612 | otherwise -- Unqual, Qual
613 -> do { mb_name <- lookupSrcOcc_maybe rdr_name
615 Just name -> return name
616 Nothing -> failWithTc (notInScope th_name) }
619 -- guessed_ns is the name space guessed from looking at the TH name
620 guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName
621 | otherwise = OccName.varName
622 occ_str = TH.occString occ
624 tcLookupTh :: Name -> TcM TcTyThing
625 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
626 -- it gives a reify-related error message on failure, whereas in the normal
627 -- tcLookup, failure is a bug.
629 = do { (gbl_env, lcl_env) <- getEnvs
630 ; case lookupNameEnv (tcl_env lcl_env) name of {
631 Just thing -> returnM thing;
633 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
634 then -- It's defined in this module
635 case lookupNameEnv (tcg_type_env gbl_env) name of
636 Just thing -> return (AGlobal thing)
637 Nothing -> failWithTc (notInEnv name)
639 else do -- It's imported
640 { (eps,hpt) <- getEpsAndHpt
642 ; case lookupType dflags hpt (eps_PTE eps) name of
643 Just thing -> return (AGlobal thing)
644 Nothing -> do { thing <- tcImportDecl name
645 ; return (AGlobal thing) }
646 -- Imported names should always be findable;
647 -- if not, we fail hard in tcImportDecl
650 notInScope :: TH.Name -> SDoc
651 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
652 ptext SLIT("is not in scope at a reify")
653 -- Ugh! Rather an indirect way to display the name
655 notInEnv :: Name -> SDoc
656 notInEnv name = quotes (ppr name) <+>
657 ptext SLIT("is not in the type environment at a reify")
659 ------------------------------
660 reifyThing :: TcTyThing -> TcM TH.Info
661 -- The only reason this is monadic is for error reporting,
662 -- which in turn is mainly for the case when TH can't express
663 -- some random GHC extension
665 reifyThing (AGlobal (AnId id))
666 = do { ty <- reifyType (idType id)
667 ; fix <- reifyFixity (idName id)
668 ; let v = reifyName id
669 ; case globalIdDetails id of
670 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
671 other -> return (TH.VarI v ty Nothing fix)
674 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
675 reifyThing (AGlobal (AClass cls)) = reifyClass cls
676 reifyThing (AGlobal (ADataCon dc))
677 = do { let name = dataConName dc
678 ; ty <- reifyType (idType (dataConWrapId dc))
679 ; fix <- reifyFixity name
680 ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
682 reifyThing (ATcId {tct_id = id, tct_type = ty})
683 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
684 -- though it may be incomplete
685 ; ty2 <- reifyType ty1
686 ; fix <- reifyFixity (idName id)
687 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
689 reifyThing (ATyVar tv ty)
690 = do { ty1 <- zonkTcType ty
691 ; ty2 <- reifyType ty1
692 ; return (TH.TyVarI (reifyName tv) ty2) }
694 ------------------------------
695 reifyTyCon :: TyCon -> TcM TH.Info
697 | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
698 | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
700 = do { let (tvs, rhs) = synTyConDefn tc
701 ; rhs' <- reifyType rhs
702 ; return (TH.TyConI $
703 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
706 = do { cxt <- reifyCxt (tyConStupidTheta tc)
707 ; let tvs = tyConTyVars tc
708 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
709 ; let name = reifyName tc
710 r_tvs = reifyTyVars tvs
711 deriv = [] -- Don't know about deriving
712 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
713 | otherwise = TH.DataD cxt name r_tvs cons deriv
714 ; return (TH.TyConI decl) }
716 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
718 | isVanillaDataCon dc
719 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
720 ; let stricts = map reifyStrict (dataConStrictMarks dc)
721 fields = dataConFieldLabels dc
725 ; ASSERT( length arg_tys == length stricts )
726 if not (null fields) then
727 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
729 if dataConIsInfix dc then
730 ASSERT( length arg_tys == 2 )
731 return (TH.InfixC (s1,a1) name (s2,a2))
733 return (TH.NormalC name (stricts `zip` arg_tys)) }
735 = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:")
738 ------------------------------
739 reifyClass :: Class -> TcM TH.Info
741 = do { cxt <- reifyCxt theta
742 ; ops <- mapM reify_op op_stuff
743 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
745 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
746 fds' = map reifyFunDep fds
747 reify_op (op, _) = do { ty <- reifyType (idType op)
748 ; return (TH.SigD (reifyName op) ty) }
750 ------------------------------
751 reifyType :: TypeRep.Type -> TcM TH.Type
752 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
753 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
754 reifyType (NoteTy _ ty) = reifyType ty
755 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
756 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
757 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
758 ; tau' <- reifyType tau
759 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
761 (tvs, cxt, tau) = tcSplitSigmaTy ty
762 reifyTypes = mapM reifyType
763 reifyCxt = mapM reifyPred
765 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
766 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
768 reifyTyVars :: [TyVar] -> [TH.Name]
769 reifyTyVars = map reifyName
771 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
772 reify_tc_app tc tys = do { tys' <- reifyTypes tys
773 ; return (foldl TH.AppT (TH.ConT tc) tys') }
775 reifyPred :: TypeRep.PredType -> TcM TH.Type
776 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
777 reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p)
780 ------------------------------
781 reifyName :: NamedThing n => n -> TH.Name
783 | isExternalName name = mk_varg pkg_str mod_str occ_str
784 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
785 -- Many of the things we reify have local bindings, and
786 -- NameL's aren't supposed to appear in binding positions, so
787 -- we use NameU. When/if we start to reify nested things, that
788 -- have free variables, we may need to generate NameL's for them.
791 mod = nameModule name
792 pkg_str = packageIdString (modulePackageId mod)
793 mod_str = moduleNameString (moduleName mod)
794 occ_str = occNameString occ
795 occ = nameOccName name
796 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
797 | OccName.isVarOcc occ = TH.mkNameG_v
798 | OccName.isTcOcc occ = TH.mkNameG_tc
799 | otherwise = pprPanic "reifyName" (ppr name)
801 ------------------------------
802 reifyFixity :: Name -> TcM TH.Fixity
804 = do { fix <- lookupFixityRn name
805 ; return (conv_fix fix) }
807 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
808 conv_dir BasicTypes.InfixR = TH.InfixR
809 conv_dir BasicTypes.InfixL = TH.InfixL
810 conv_dir BasicTypes.InfixN = TH.InfixN
812 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
813 reifyStrict MarkedStrict = TH.IsStrict
814 reifyStrict MarkedUnboxed = TH.IsStrict
815 reifyStrict NotMarkedStrict = TH.NotStrict
817 ------------------------------
818 noTH :: LitString -> SDoc -> TcM a
819 noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+>
820 ptext SLIT("in Template Haskell:"),