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)
82 * In GHCi, variables bound by a previous command are treated
83 as impLevel, because we have bytecode for them.
85 * Variables are bound at the "current level"
87 * The current level starts off at topLevel (= 1)
89 * The level is decremented by splicing $(..)
90 incremented by brackets [| |]
91 incremented by name-quoting 'f
93 When a variable is used, we compare
94 bind: binding level, and
95 use: current level at usage site
98 bind > use Always error (bound later than used)
101 bind = use Always OK (bound same stage as used)
102 [| \x -> $(f [| x |]) |]
104 bind < use Inside brackets, it depends
108 For (bind < use) inside brackets, there are three cases:
109 - Imported things OK f = [| map |]
110 - Top-level things OK g = [| f |]
111 - Non-top-level Only if there is a liftable instance
112 h = \(x:Int) -> [| x |]
114 See Note [What is a top-level Id?]
118 A quoted name 'n is a bit like a quoted expression [| n |], except that we
119 have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
120 the use-level to account for the brackets, the cases are:
129 See Note [What is a top-level Id?] in TcEnv. Examples:
131 f 'map -- OK; also for top-level defns of this module
133 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
134 -- cross-stage lifting
136 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
138 [| \x. $(f 'x) |] -- OK
141 Note [What is a top-level Id?]
142 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
143 In the level-control criteria above, we need to know what a "top level Id" is.
144 There are three kinds:
145 * Imported from another module (GlobalId, ExternalName)
146 * Bound at the top level of this module (ExternalName)
147 * In GHCi, bound by a previous stmt (GlobalId)
148 It's strange that there is no one criterion tht picks out all three, but that's
149 how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids
150 bound in an earlier Stmt, but what module would you choose? See
151 Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
153 The predicate we use is TcEnv.thTopLevelId.
156 %************************************************************************
158 \subsection{Main interface + stubs for the non-GHCI case
160 %************************************************************************
163 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
164 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
165 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
166 -- None of these functions add constraints to the LIE
169 tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
170 tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
174 %************************************************************************
176 \subsection{Quoting an expression}
178 %************************************************************************
180 Note [Handling brackets]
181 ~~~~~~~~~~~~~~~~~~~~~~~~
182 Source: f = [| Just $(g 3) |]
183 The [| |] part is a HsBracket
185 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
186 The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
187 The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
189 Desugared: f = do { s7 <- g Int 3
190 ; return (ConE "Data.Maybe.Just" s7) }
193 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
194 tcBracket brack res_ty
195 = getStage `thenM` \ level ->
196 case bracketOK level of {
197 Nothing -> failWithTc (illegalBracket level) ;
200 -- Typecheck expr to make sure it is valid,
201 -- but throw away the results. We'll type check
202 -- it again when we actually use it.
204 newMutVar [] `thenM` \ pending_splices ->
205 getLIEVar `thenM` \ lie_var ->
207 setStage (Brack next_level pending_splices lie_var) (
208 getLIE (tc_bracket next_level brack)
209 ) `thenM` \ (meta_ty, lie) ->
210 tcSimplifyBracket lie `thenM_`
212 -- Make the expected type have the right shape
213 boxyUnify meta_ty res_ty `thenM_`
215 -- Return the original expression, not the type-decorated one
216 readMutVar pending_splices `thenM` \ pendings ->
217 returnM (noLoc (HsBracketOut brack pendings))
220 tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
221 tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
222 = do { thing <- tcLookup name
224 AGlobal _ -> return ()
225 ATcId { tct_level = bind_lvl, tct_id = id }
226 | thTopLevelId id -- C.f thTopLevelId case of
227 -> keepAliveTc id -- TcExpr.thBrackId
229 -> do { checkTc (use_lvl == bind_lvl)
230 (quotedNameStageErr name) }
231 other -> pprPanic "th_bracket" (ppr name)
233 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
236 tc_bracket use_lvl (ExpBr expr)
237 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
238 ; tcMonoExpr expr any_ty
239 ; tcMetaTy expQTyConName }
240 -- Result type is Expr (= Q Exp)
242 tc_bracket use_lvl (TypBr typ)
243 = do { tcHsSigType ExprSigCtxt typ
244 ; tcMetaTy typeQTyConName }
245 -- Result type is Type (= Q Typ)
247 tc_bracket use_lvl (DecBr decls)
248 = do { tcTopSrcDecls emptyModDetails decls
249 -- Typecheck the declarations, dicarding the result
250 -- We'll get all that stuff later, when we splice it in
252 ; decl_ty <- tcMetaTy decTyConName
253 ; q_ty <- tcMetaTy qTyConName
254 ; return (mkAppTy q_ty (mkListTy decl_ty))
255 -- Result type is Q [Dec]
258 tc_bracket use_lvl (PatBr _)
259 = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet"))
262 = sep [ ptext SLIT("Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
263 , ptext SLIT("must be used at the same stage at which is is bound")]
267 %************************************************************************
269 \subsection{Splicing an expression}
271 %************************************************************************
274 tcSpliceExpr (HsSplice name expr) res_ty
275 = setSrcSpan (getLoc expr) $
276 getStage `thenM` \ level ->
277 case spliceOK level of {
278 Nothing -> failWithTc (illegalSplice level) ;
282 Comp -> do { e <- tcTopSplice expr res_ty
283 ; returnM (unLoc e) } ;
284 Brack _ ps_var lie_var ->
286 -- A splice inside brackets
287 -- NB: ignore res_ty, apart from zapping it to a mono-type
288 -- e.g. [| reverse $(h 4) |]
289 -- Here (h 4) :: Q Exp
290 -- but $(h 4) :: forall a.a i.e. anything!
292 unBox res_ty `thenM_`
293 tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
294 setStage (Splice next_level) (
296 tcMonoExpr expr meta_exp_ty
299 -- Write the pending splice into the bucket
300 readMutVar ps_var `thenM` \ ps ->
301 writeMutVar ps_var ((name,expr') : ps) `thenM_`
303 returnM (panic "tcSpliceExpr") -- The returned expression is ignored
306 -- tcTopSplice used to have this:
307 -- Note that we do not decrement the level (to -1) before
308 -- typechecking the expression. For example:
309 -- f x = $( ...$(g 3) ... )
310 -- The recursive call to tcMonoExpr will simply expand the
311 -- inner escape before dealing with the outer one
313 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
314 tcTopSplice expr res_ty
315 = tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
317 -- Typecheck the expression
318 tcTopSpliceExpr expr meta_exp_ty `thenM` \ zonked_q_expr ->
320 -- Run the expression
321 traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
322 runMetaE convertToHsExpr zonked_q_expr `thenM` \ expr2 ->
324 traceTc (text "Got result" <+> ppr expr2) `thenM_`
326 showSplice "expression"
327 zonked_q_expr (ppr expr2) `thenM_`
329 -- Rename it, but bale out if there are errors
330 -- otherwise the type checker just gives more spurious errors
331 checkNoErrs (rnLExpr expr2) `thenM` \ (exp3, fvs) ->
333 tcMonoExpr exp3 res_ty
336 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
337 -- Type check an expression that is the body of a top-level splice
338 -- (the caller will compile and run it)
339 tcTopSpliceExpr expr meta_ty
340 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
341 -- if the type checker fails!
343 setStage topSpliceStage $ do
346 do { recordThUse -- Record that TH is used (for pkg depdendency)
348 -- Typecheck the expression
349 ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
351 -- Solve the constraints
352 ; const_binds <- tcSimplifyTop lie
355 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
359 %************************************************************************
363 %************************************************************************
365 Very like splicing an expression, but we don't yet share code.
368 kcSpliceType (HsSplice name hs_expr)
369 = setSrcSpan (getLoc hs_expr) $ do
371 ; case spliceOK level of {
372 Nothing -> failWithTc (illegalSplice level) ;
373 Just next_level -> do
376 Comp -> do { (t,k) <- kcTopSpliceType hs_expr
377 ; return (unLoc t, k) } ;
378 Brack _ ps_var lie_var -> do
380 { -- A splice inside brackets
381 ; meta_ty <- tcMetaTy typeQTyConName
382 ; expr' <- setStage (Splice next_level) $
384 tcMonoExpr hs_expr meta_ty
386 -- Write the pending splice into the bucket
387 ; ps <- readMutVar ps_var
388 ; writeMutVar ps_var ((name,expr') : ps)
390 -- e.g. [| Int -> $(h 4) |]
391 -- Here (h 4) :: Q Type
392 -- but $(h 4) :: forall a.a i.e. any kind
394 ; returnM (panic "kcSpliceType", kind) -- The returned type is ignored
397 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
399 = do { meta_ty <- tcMetaTy typeQTyConName
401 -- Typecheck the expression
402 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
404 -- Run the expression
405 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
406 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
408 ; traceTc (text "Got result" <+> ppr hs_ty2)
410 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
412 -- Rename it, but bale out if there are errors
413 -- otherwise the type checker just gives more spurious errors
414 ; let doc = ptext SLIT("In the spliced type") <+> ppr hs_ty2
415 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
420 %************************************************************************
422 \subsection{Splicing an expression}
424 %************************************************************************
427 -- Always at top level
428 -- Type sig at top of file:
429 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
431 = do { meta_dec_ty <- tcMetaTy decTyConName
432 ; meta_q_ty <- tcMetaTy qTyConName
433 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
434 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
436 -- Run the expression
437 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
438 ; decls <- runMetaD convertToHsDecls zonked_q_expr
440 ; traceTc (text "Got result" <+> vcat (map ppr decls))
441 ; showSplice "declarations"
443 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
446 where handleErrors :: [Either a Message] -> TcM [a]
447 handleErrors [] = return []
448 handleErrors (Left x:xs) = liftM (x:) (handleErrors xs)
449 handleErrors (Right m:xs) = do addErrTc m
454 %************************************************************************
456 \subsection{Running an expression}
458 %************************************************************************
461 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
462 -> LHsExpr Id -- Of type (Q Exp)
463 -> TcM (LHsExpr RdrName)
466 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
467 -> LHsExpr Id -- Of type (Q Type)
468 -> TcM (LHsType RdrName)
471 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
472 -> LHsExpr Id -- Of type Q [Dec]
473 -> TcM [LHsDecl RdrName]
476 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
477 -> LHsExpr Id -- Of type X
478 -> TcM hs_syn -- Of type t
481 ds_expr <- initDsTc (dsLExpr expr)
482 -- Compile and link it; might fail if linking fails
483 ; hsc_env <- getTopEnv
484 ; src_span <- getSrcSpanM
485 ; either_hval <- tryM $ ioToTcRn $
486 HscMain.compileExpr hsc_env src_span ds_expr
487 ; case either_hval of {
488 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
491 { -- Coerce it to Q t, and run it
493 -- Running might fail if it throws an exception of any kind (hence tryAllM)
494 -- including, say, a pattern-match exception in the code we are running
496 -- We also do the TH -> HS syntax conversion inside the same
497 -- exception-cacthing thing so that if there are any lurking
498 -- exceptions in the data structure returned by hval, we'll
499 -- encounter them inside the try
501 -- See Note [Exceptions in TH]
502 either_tval <- tryAllM $ do
503 { th_syn <- TH.runQ (unsafeCoerce# hval)
504 ; case convert (getLoc expr) th_syn of
505 Left err -> failWithTc err
506 Right hs_syn -> return hs_syn }
508 ; case either_tval of
510 Left exn | Just s <- Exception.userErrors exn
511 , s == "IOEnv failure"
512 -> failM -- Error already in Tc monad
513 | otherwise -> failWithTc (mk_msg "run" exn) -- Exception
516 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
517 nest 2 (text (Panic.showException exn)),
518 nest 2 (text "Code:" <+> ppr expr)]
521 Note [Exceptions in TH]
522 ~~~~~~~~~~~~~~~~~~~~~~~
523 Supppose we have something like this
527 f n | n>3 = fail "Too many declarations"
530 The 'fail' is a user-generated failure, and should be displayed as a
531 perfectly ordinary compiler error message, not a panic or anything
532 like that. Here's how it's processed:
534 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
535 effectively transforms (fail s) to
536 qReport True s >> fail
537 where 'qReport' comes from the Quasi class and fail from its monad
540 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
541 (qReport True s) by using addErr to add an error message to the bag of errors.
542 The 'fail' in TcM raises a UserError, with the uninteresting string
545 * So, when running a splice, we catch all exceptions; then for
546 - a UserError "IOEnv failure", we assume the error is already
547 in the error-bag (above)
548 - other errors, we add an error to the bag
552 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
555 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
556 qNewName s = do { u <- newUnique
558 ; return (TH.mkNameU s i) }
560 qReport True msg = addErr (text msg)
561 qReport False msg = addReport (text msg)
563 qCurrentModule = do { m <- getModule;
564 return (moduleNameString (moduleName m)) }
565 -- ToDo: is throwing away the package name ok here?
569 -- For qRecover, discard error messages if
570 -- the recovery action is chosen. Otherwise
571 -- we'll only fail higher up. c.f. tryTcLIE_
572 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
574 Just val -> do { addMessages msgs -- There might be warnings
576 Nothing -> recover -- Discard all msgs
579 qRunIO io = ioToTcRn io
583 %************************************************************************
585 \subsection{Errors and contexts}
587 %************************************************************************
590 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
591 showSplice what before after
592 = getSrcSpanM `thenM` \ loc ->
593 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
594 nest 2 (sep [nest 2 (ppr before),
599 = ptext SLIT("Illegal bracket at level") <+> ppr level
602 = ptext SLIT("Illegal splice at level") <+> ppr level
608 %************************************************************************
612 %************************************************************************
616 reify :: TH.Name -> TcM TH.Info
618 = do { name <- lookupThName th_name
619 ; thing <- tcLookupTh name
620 -- ToDo: this tcLookup could fail, which would give a
621 -- rather unhelpful error message
622 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
626 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
627 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
628 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
630 lookupThName :: TH.Name -> TcM Name
631 lookupThName th_name@(TH.Name occ flavour)
632 = do { let rdr_name = thRdrName guessed_ns occ_str flavour
634 -- Repeat much of lookupOccRn, becase we want
635 -- to report errors in a TH-relevant way
636 ; rdr_env <- getLocalRdrEnv
637 ; case lookupLocalRdrEnv rdr_env rdr_name of
638 Just name -> return name
639 Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
640 -> lookupImportedName rdr_name
641 | otherwise -- Unqual, Qual
642 -> do { mb_name <- lookupSrcOcc_maybe rdr_name
644 Just name -> return name
645 Nothing -> failWithTc (notInScope th_name) }
648 -- guessed_ns is the name space guessed from looking at the TH name
649 guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName
650 | otherwise = OccName.varName
651 occ_str = TH.occString occ
653 tcLookupTh :: Name -> TcM TcTyThing
654 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
655 -- it gives a reify-related error message on failure, whereas in the normal
656 -- tcLookup, failure is a bug.
658 = do { (gbl_env, lcl_env) <- getEnvs
659 ; case lookupNameEnv (tcl_env lcl_env) name of {
660 Just thing -> returnM thing;
662 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
663 then -- It's defined in this module
664 case lookupNameEnv (tcg_type_env gbl_env) name of
665 Just thing -> return (AGlobal thing)
666 Nothing -> failWithTc (notInEnv name)
668 else do -- It's imported
669 { (eps,hpt) <- getEpsAndHpt
671 ; case lookupType dflags hpt (eps_PTE eps) name of
672 Just thing -> return (AGlobal thing)
673 Nothing -> do { thing <- tcImportDecl name
674 ; return (AGlobal thing) }
675 -- Imported names should always be findable;
676 -- if not, we fail hard in tcImportDecl
679 notInScope :: TH.Name -> SDoc
680 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
681 ptext SLIT("is not in scope at a reify")
682 -- Ugh! Rather an indirect way to display the name
684 notInEnv :: Name -> SDoc
685 notInEnv name = quotes (ppr name) <+>
686 ptext SLIT("is not in the type environment at a reify")
688 ------------------------------
689 reifyThing :: TcTyThing -> TcM TH.Info
690 -- The only reason this is monadic is for error reporting,
691 -- which in turn is mainly for the case when TH can't express
692 -- some random GHC extension
694 reifyThing (AGlobal (AnId id))
695 = do { ty <- reifyType (idType id)
696 ; fix <- reifyFixity (idName id)
697 ; let v = reifyName id
698 ; case globalIdDetails id of
699 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
700 other -> return (TH.VarI v ty Nothing fix)
703 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
704 reifyThing (AGlobal (AClass cls)) = reifyClass cls
705 reifyThing (AGlobal (ADataCon dc))
706 = do { let name = dataConName dc
707 ; ty <- reifyType (idType (dataConWrapId dc))
708 ; fix <- reifyFixity name
709 ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
711 reifyThing (ATcId {tct_id = id, tct_type = ty})
712 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
713 -- though it may be incomplete
714 ; ty2 <- reifyType ty1
715 ; fix <- reifyFixity (idName id)
716 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
718 reifyThing (ATyVar tv ty)
719 = do { ty1 <- zonkTcType ty
720 ; ty2 <- reifyType ty1
721 ; return (TH.TyVarI (reifyName tv) ty2) }
723 ------------------------------
724 reifyTyCon :: TyCon -> TcM TH.Info
726 | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
727 | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
729 = do { let (tvs, rhs) = synTyConDefn tc
730 ; rhs' <- reifyType rhs
731 ; return (TH.TyConI $
732 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
735 = do { cxt <- reifyCxt (tyConStupidTheta tc)
736 ; let tvs = tyConTyVars tc
737 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
738 ; let name = reifyName tc
739 r_tvs = reifyTyVars tvs
740 deriv = [] -- Don't know about deriving
741 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
742 | otherwise = TH.DataD cxt name r_tvs cons deriv
743 ; return (TH.TyConI decl) }
745 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
747 | isVanillaDataCon dc
748 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
749 ; let stricts = map reifyStrict (dataConStrictMarks dc)
750 fields = dataConFieldLabels dc
754 ; ASSERT( length arg_tys == length stricts )
755 if not (null fields) then
756 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
758 if dataConIsInfix dc then
759 ASSERT( length arg_tys == 2 )
760 return (TH.InfixC (s1,a1) name (s2,a2))
762 return (TH.NormalC name (stricts `zip` arg_tys)) }
764 = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:")
767 ------------------------------
768 reifyClass :: Class -> TcM TH.Info
770 = do { cxt <- reifyCxt theta
771 ; ops <- mapM reify_op op_stuff
772 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
774 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
775 fds' = map reifyFunDep fds
776 reify_op (op, _) = do { ty <- reifyType (idType op)
777 ; return (TH.SigD (reifyName op) ty) }
779 ------------------------------
780 reifyType :: TypeRep.Type -> TcM TH.Type
781 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
782 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
783 reifyType (NoteTy _ ty) = reifyType ty
784 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
785 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
786 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
787 ; tau' <- reifyType tau
788 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
790 (tvs, cxt, tau) = tcSplitSigmaTy ty
791 reifyTypes = mapM reifyType
792 reifyCxt = mapM reifyPred
794 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
795 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
797 reifyTyVars :: [TyVar] -> [TH.Name]
798 reifyTyVars = map reifyName
800 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
801 reify_tc_app tc tys = do { tys' <- reifyTypes tys
802 ; return (foldl TH.AppT (TH.ConT tc) tys') }
804 reifyPred :: TypeRep.PredType -> TcM TH.Type
805 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
806 reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p)
809 ------------------------------
810 reifyName :: NamedThing n => n -> TH.Name
812 | isExternalName name = mk_varg pkg_str mod_str occ_str
813 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
814 -- Many of the things we reify have local bindings, and
815 -- NameL's aren't supposed to appear in binding positions, so
816 -- we use NameU. When/if we start to reify nested things, that
817 -- have free variables, we may need to generate NameL's for them.
820 mod = nameModule name
821 pkg_str = packageIdString (modulePackageId mod)
822 mod_str = moduleNameString (moduleName mod)
823 occ_str = occNameString occ
824 occ = nameOccName name
825 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
826 | OccName.isVarOcc occ = TH.mkNameG_v
827 | OccName.isTcOcc occ = TH.mkNameG_tc
828 | otherwise = pprPanic "reifyName" (ppr name)
830 ------------------------------
831 reifyFixity :: Name -> TcM TH.Fixity
833 = do { fix <- lookupFixityRn name
834 ; return (conv_fix fix) }
836 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
837 conv_dir BasicTypes.InfixR = TH.InfixR
838 conv_dir BasicTypes.InfixL = TH.InfixL
839 conv_dir BasicTypes.InfixN = TH.InfixN
841 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
842 reifyStrict MarkedStrict = TH.IsStrict
843 reifyStrict MarkedUnboxed = TH.IsStrict
844 reifyStrict NotMarkedStrict = TH.NotStrict
846 ------------------------------
847 noTH :: LitString -> SDoc -> TcM a
848 noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+>
849 ptext SLIT("in Template Haskell:"),