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 )
79 %************************************************************************
81 \subsection{Main interface + stubs for the non-GHCI case
83 %************************************************************************
86 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
87 tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
88 kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
89 -- None of these functions add constraints to the LIE
92 tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
93 tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
97 %************************************************************************
99 \subsection{Quoting an expression}
101 %************************************************************************
103 Note [Handling brackets]
104 ~~~~~~~~~~~~~~~~~~~~~~~~
105 Source: f = [| Just $(g 3) |]
106 The [| |] part is a HsBracket
108 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
109 The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
110 The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
112 Desugared: f = do { s7 <- g Int 3
113 ; return (ConE "Data.Maybe.Just" s7) }
116 tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
117 tcBracket brack res_ty
118 = getStage `thenM` \ level ->
119 case bracketOK level of {
120 Nothing -> failWithTc (illegalBracket level) ;
123 -- Typecheck expr to make sure it is valid,
124 -- but throw away the results. We'll type check
125 -- it again when we actually use it.
127 newMutVar [] `thenM` \ pending_splices ->
128 getLIEVar `thenM` \ lie_var ->
130 setStage (Brack next_level pending_splices lie_var) (
131 getLIE (tc_bracket brack)
132 ) `thenM` \ (meta_ty, lie) ->
133 tcSimplifyBracket lie `thenM_`
135 -- Make the expected type have the right shape
136 boxyUnify meta_ty res_ty `thenM_`
138 -- Return the original expression, not the type-decorated one
139 readMutVar pending_splices `thenM` \ pendings ->
140 returnM (noLoc (HsBracketOut brack pendings))
143 tc_bracket :: HsBracket Name -> TcM TcType
144 tc_bracket (VarBr name) -- Note [Quoting names]
145 = do { thing <- tcLookup name
147 AGlobal _ -> return ()
148 ATcId { tct_level = bind_lvl }
149 | isExternalName name -- C.f isExternalName case of
150 -> keepAliveTc name -- TcExpr.thBrackId
152 -> do { use_stage <- getStage
153 ; checkTc (thLevel use_stage == bind_lvl)
154 (quotedNameStageErr name) }
155 other -> pprPanic "th_bracket" (ppr name)
157 ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
160 tc_bracket (ExpBr expr)
161 = do { any_ty <- newFlexiTyVarTy liftedTypeKind
162 ; tcMonoExpr expr any_ty
163 ; tcMetaTy expQTyConName }
164 -- Result type is Expr (= Q Exp)
166 tc_bracket (TypBr typ)
167 = do { tcHsSigType ExprSigCtxt typ
168 ; tcMetaTy typeQTyConName }
169 -- Result type is Type (= Q Typ)
171 tc_bracket (DecBr decls)
172 = do { tcTopSrcDecls emptyModDetails decls
173 -- Typecheck the declarations, dicarding the result
174 -- We'll get all that stuff later, when we splice it in
176 ; decl_ty <- tcMetaTy decTyConName
177 ; q_ty <- tcMetaTy qTyConName
178 ; return (mkAppTy q_ty (mkListTy decl_ty))
179 -- Result type is Q [Dec]
183 = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet"))
186 = sep [ ptext SLIT("Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
187 , ptext SLIT("must be used at the same stage at which is is bound")]
192 A quoted name is a bit like a quoted expression, except that we have no
193 cross-stage lifting (c.f. TcExpr.thBrackId). Examples:
195 f 'map -- OK; also for top-level defns of this module
197 \x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
198 -- cross-stage lifting
200 \y. [| \x. $(f 'y) |] -- Not ok (same reason)
202 [| \x. $(f 'x) |] -- OK
204 %************************************************************************
206 \subsection{Splicing an expression}
208 %************************************************************************
211 tcSpliceExpr (HsSplice name expr) res_ty
212 = setSrcSpan (getLoc expr) $
213 getStage `thenM` \ level ->
214 case spliceOK level of {
215 Nothing -> failWithTc (illegalSplice level) ;
219 Comp -> do { e <- tcTopSplice expr res_ty
220 ; returnM (unLoc e) } ;
221 Brack _ ps_var lie_var ->
223 -- A splice inside brackets
224 -- NB: ignore res_ty, apart from zapping it to a mono-type
225 -- e.g. [| reverse $(h 4) |]
226 -- Here (h 4) :: Q Exp
227 -- but $(h 4) :: forall a.a i.e. anything!
229 unBox res_ty `thenM_`
230 tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
231 setStage (Splice next_level) (
233 tcMonoExpr expr meta_exp_ty
236 -- Write the pending splice into the bucket
237 readMutVar ps_var `thenM` \ ps ->
238 writeMutVar ps_var ((name,expr') : ps) `thenM_`
240 returnM (panic "tcSpliceExpr") -- The returned expression is ignored
243 -- tcTopSplice used to have this:
244 -- Note that we do not decrement the level (to -1) before
245 -- typechecking the expression. For example:
246 -- f x = $( ...$(g 3) ... )
247 -- The recursive call to tcMonoExpr will simply expand the
248 -- inner escape before dealing with the outer one
250 tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
251 tcTopSplice expr res_ty
252 = tcMetaTy expQTyConName `thenM` \ meta_exp_ty ->
254 -- Typecheck the expression
255 tcTopSpliceExpr expr meta_exp_ty `thenM` \ zonked_q_expr ->
257 -- Run the expression
258 traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
259 runMetaE convertToHsExpr zonked_q_expr `thenM` \ expr2 ->
261 traceTc (text "Got result" <+> ppr expr2) `thenM_`
263 showSplice "expression"
264 zonked_q_expr (ppr expr2) `thenM_`
266 -- Rename it, but bale out if there are errors
267 -- otherwise the type checker just gives more spurious errors
268 checkNoErrs (rnLExpr expr2) `thenM` \ (exp3, fvs) ->
270 tcMonoExpr exp3 res_ty
273 tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
274 -- Type check an expression that is the body of a top-level splice
275 -- (the caller will compile and run it)
276 tcTopSpliceExpr expr meta_ty
277 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
278 -- if the type checker fails!
280 setStage topSpliceStage $ do
283 do { recordThUse -- Record that TH is used (for pkg depdendency)
285 -- Typecheck the expression
286 ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
288 -- Solve the constraints
289 ; const_binds <- tcSimplifyTop lie
292 ; zonkTopLExpr (mkHsDictLet const_binds expr') }
296 %************************************************************************
300 %************************************************************************
302 Very like splicing an expression, but we don't yet share code.
305 kcSpliceType (HsSplice name hs_expr)
306 = setSrcSpan (getLoc hs_expr) $ do
308 ; case spliceOK level of {
309 Nothing -> failWithTc (illegalSplice level) ;
310 Just next_level -> do
313 Comp -> do { (t,k) <- kcTopSpliceType hs_expr
314 ; return (unLoc t, k) } ;
315 Brack _ ps_var lie_var -> do
317 { -- A splice inside brackets
318 ; meta_ty <- tcMetaTy typeQTyConName
319 ; expr' <- setStage (Splice next_level) $
321 tcMonoExpr hs_expr meta_ty
323 -- Write the pending splice into the bucket
324 ; ps <- readMutVar ps_var
325 ; writeMutVar ps_var ((name,expr') : ps)
327 -- e.g. [| Int -> $(h 4) |]
328 -- Here (h 4) :: Q Type
329 -- but $(h 4) :: forall a.a i.e. any kind
331 ; returnM (panic "kcSpliceType", kind) -- The returned type is ignored
334 kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
336 = do { meta_ty <- tcMetaTy typeQTyConName
338 -- Typecheck the expression
339 ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
341 -- Run the expression
342 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
343 ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
345 ; traceTc (text "Got result" <+> ppr hs_ty2)
347 ; showSplice "type" zonked_q_expr (ppr hs_ty2)
349 -- Rename it, but bale out if there are errors
350 -- otherwise the type checker just gives more spurious errors
351 ; let doc = ptext SLIT("In the spliced type") <+> ppr hs_ty2
352 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
357 %************************************************************************
359 \subsection{Splicing an expression}
361 %************************************************************************
364 -- Always at top level
365 -- Type sig at top of file:
366 -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
368 = do { meta_dec_ty <- tcMetaTy decTyConName
369 ; meta_q_ty <- tcMetaTy qTyConName
370 ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
371 ; zonked_q_expr <- tcTopSpliceExpr expr list_q
373 -- Run the expression
374 ; traceTc (text "About to run" <+> ppr zonked_q_expr)
375 ; decls <- runMetaD convertToHsDecls zonked_q_expr
377 ; traceTc (text "Got result" <+> vcat (map ppr decls))
378 ; showSplice "declarations"
380 (ppr (getLoc expr) $$ (vcat (map ppr decls)))
383 where handleErrors :: [Either a Message] -> TcM [a]
384 handleErrors [] = return []
385 handleErrors (Left x:xs) = liftM (x:) (handleErrors xs)
386 handleErrors (Right m:xs) = do addErrTc m
391 %************************************************************************
393 \subsection{Running an expression}
395 %************************************************************************
398 runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
399 -> LHsExpr Id -- Of type (Q Exp)
400 -> TcM (LHsExpr RdrName)
403 runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
404 -> LHsExpr Id -- Of type (Q Type)
405 -> TcM (LHsType RdrName)
408 runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
409 -> LHsExpr Id -- Of type Q [Dec]
410 -> TcM [LHsDecl RdrName]
413 runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
414 -> LHsExpr Id -- Of type X
415 -> TcM hs_syn -- Of type t
418 ds_expr <- initDsTc (dsLExpr expr)
419 -- Compile and link it; might fail if linking fails
420 ; hsc_env <- getTopEnv
421 ; src_span <- getSrcSpanM
422 ; either_hval <- tryM $ ioToTcRn $
423 HscMain.compileExpr hsc_env src_span ds_expr
424 ; case either_hval of {
425 Left exn -> failWithTc (mk_msg "compile and link" exn) ;
428 { -- Coerce it to Q t, and run it
430 -- Running might fail if it throws an exception of any kind (hence tryAllM)
431 -- including, say, a pattern-match exception in the code we are running
433 -- We also do the TH -> HS syntax conversion inside the same
434 -- exception-cacthing thing so that if there are any lurking
435 -- exceptions in the data structure returned by hval, we'll
436 -- encounter them inside the try
438 -- See Note [Exceptions in TH]
439 either_tval <- tryAllM $ do
440 { th_syn <- TH.runQ (unsafeCoerce# hval)
441 ; case convert (getLoc expr) th_syn of
442 Left err -> failWithTc err
443 Right hs_syn -> return hs_syn }
445 ; case either_tval of
447 Left exn | Just s <- Exception.userErrors exn
448 , s == "IOEnv failure"
449 -> failM -- Error already in Tc monad
450 | otherwise -> failWithTc (mk_msg "run" exn) -- Exception
453 mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
454 nest 2 (text (Panic.showException exn)),
455 nest 2 (text "Code:" <+> ppr expr)]
458 Note [Exceptions in TH]
459 ~~~~~~~~~~~~~~~~~~~~~~~
460 Supppose we have something like this
464 f n | n>3 = fail "Too many declarations"
467 The 'fail' is a user-generated failure, and should be displayed as a
468 perfectly ordinary compiler error message, not a panic or anything
469 like that. Here's how it's processed:
471 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
472 effectively transforms (fail s) to
473 qReport True s >> fail
474 where 'qReport' comes from the Quasi class and fail from its monad
477 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
478 (qReport True s) by using addErr to add an error message to the bag of errors.
479 The 'fail' in TcM raises a UserError, with the uninteresting string
482 * So, when running a splice, we catch all exceptions; then for
483 - a UserError "IOEnv failure", we assume the error is already
484 in the error-bag (above)
485 - other errors, we add an error to the bag
489 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
492 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
493 qNewName s = do { u <- newUnique
495 ; return (TH.mkNameU s i) }
497 qReport True msg = addErr (text msg)
498 qReport False msg = addReport (text msg)
500 qCurrentModule = do { m <- getModule;
501 return (moduleNameString (moduleName m)) }
502 -- ToDo: is throwing away the package name ok here?
506 -- For qRecover, discard error messages if
507 -- the recovery action is chosen. Otherwise
508 -- we'll only fail higher up. c.f. tryTcLIE_
509 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
511 Just val -> do { addMessages msgs -- There might be warnings
513 Nothing -> recover -- Discard all msgs
516 qRunIO io = ioToTcRn io
520 %************************************************************************
522 \subsection{Errors and contexts}
524 %************************************************************************
527 showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
528 showSplice what before after
529 = getSrcSpanM `thenM` \ loc ->
530 traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
531 nest 2 (sep [nest 2 (ppr before),
536 = ptext SLIT("Illegal bracket at level") <+> ppr level
539 = ptext SLIT("Illegal splice at level") <+> ppr level
545 %************************************************************************
549 %************************************************************************
553 reify :: TH.Name -> TcM TH.Info
555 = do { name <- lookupThName th_name
556 ; thing <- tcLookupTh name
557 -- ToDo: this tcLookup could fail, which would give a
558 -- rather unhelpful error message
559 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
563 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
564 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
565 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
567 lookupThName :: TH.Name -> TcM Name
568 lookupThName th_name@(TH.Name occ flavour)
569 = do { let rdr_name = thRdrName guessed_ns occ_str flavour
571 -- Repeat much of lookupOccRn, becase we want
572 -- to report errors in a TH-relevant way
573 ; rdr_env <- getLocalRdrEnv
574 ; case lookupLocalRdrEnv rdr_env rdr_name of
575 Just name -> return name
576 Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
577 -> lookupImportedName rdr_name
578 | otherwise -- Unqual, Qual
579 -> do { mb_name <- lookupSrcOcc_maybe rdr_name
581 Just name -> return name
582 Nothing -> failWithTc (notInScope th_name) }
585 -- guessed_ns is the name space guessed from looking at the TH name
586 guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName
587 | otherwise = OccName.varName
588 occ_str = TH.occString occ
590 tcLookupTh :: Name -> TcM TcTyThing
591 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
592 -- it gives a reify-related error message on failure, whereas in the normal
593 -- tcLookup, failure is a bug.
595 = do { (gbl_env, lcl_env) <- getEnvs
596 ; case lookupNameEnv (tcl_env lcl_env) name of {
597 Just thing -> returnM thing;
599 { if nameIsLocalOrFrom (tcg_mod gbl_env) name
600 then -- It's defined in this module
601 case lookupNameEnv (tcg_type_env gbl_env) name of
602 Just thing -> return (AGlobal thing)
603 Nothing -> failWithTc (notInEnv name)
605 else do -- It's imported
606 { (eps,hpt) <- getEpsAndHpt
608 ; case lookupType dflags hpt (eps_PTE eps) name of
609 Just thing -> return (AGlobal thing)
610 Nothing -> do { thing <- tcImportDecl name
611 ; return (AGlobal thing) }
612 -- Imported names should always be findable;
613 -- if not, we fail hard in tcImportDecl
616 notInScope :: TH.Name -> SDoc
617 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
618 ptext SLIT("is not in scope at a reify")
619 -- Ugh! Rather an indirect way to display the name
621 notInEnv :: Name -> SDoc
622 notInEnv name = quotes (ppr name) <+>
623 ptext SLIT("is not in the type environment at a reify")
625 ------------------------------
626 reifyThing :: TcTyThing -> TcM TH.Info
627 -- The only reason this is monadic is for error reporting,
628 -- which in turn is mainly for the case when TH can't express
629 -- some random GHC extension
631 reifyThing (AGlobal (AnId id))
632 = do { ty <- reifyType (idType id)
633 ; fix <- reifyFixity (idName id)
634 ; let v = reifyName id
635 ; case globalIdDetails id of
636 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
637 other -> return (TH.VarI v ty Nothing fix)
640 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
641 reifyThing (AGlobal (AClass cls)) = reifyClass cls
642 reifyThing (AGlobal (ADataCon dc))
643 = do { let name = dataConName dc
644 ; ty <- reifyType (idType (dataConWrapId dc))
645 ; fix <- reifyFixity name
646 ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
648 reifyThing (ATcId {tct_id = id, tct_type = ty})
649 = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
650 -- though it may be incomplete
651 ; ty2 <- reifyType ty1
652 ; fix <- reifyFixity (idName id)
653 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
655 reifyThing (ATyVar tv ty)
656 = do { ty1 <- zonkTcType ty
657 ; ty2 <- reifyType ty1
658 ; return (TH.TyVarI (reifyName tv) ty2) }
660 ------------------------------
661 reifyTyCon :: TyCon -> TcM TH.Info
663 | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
664 | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
666 = do { let (tvs, rhs) = synTyConDefn tc
667 ; rhs' <- reifyType rhs
668 ; return (TH.TyConI $
669 TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
672 = do { cxt <- reifyCxt (tyConStupidTheta tc)
673 ; let tvs = tyConTyVars tc
674 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
675 ; let name = reifyName tc
676 r_tvs = reifyTyVars tvs
677 deriv = [] -- Don't know about deriving
678 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
679 | otherwise = TH.DataD cxt name r_tvs cons deriv
680 ; return (TH.TyConI decl) }
682 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
684 | isVanillaDataCon dc
685 = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
686 ; let stricts = map reifyStrict (dataConStrictMarks dc)
687 fields = dataConFieldLabels dc
691 ; ASSERT( length arg_tys == length stricts )
692 if not (null fields) then
693 return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
695 if dataConIsInfix dc then
696 ASSERT( length arg_tys == 2 )
697 return (TH.InfixC (s1,a1) name (s2,a2))
699 return (TH.NormalC name (stricts `zip` arg_tys)) }
701 = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:")
704 ------------------------------
705 reifyClass :: Class -> TcM TH.Info
707 = do { cxt <- reifyCxt theta
708 ; ops <- mapM reify_op op_stuff
709 ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
711 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
712 fds' = map reifyFunDep fds
713 reify_op (op, _) = do { ty <- reifyType (idType op)
714 ; return (TH.SigD (reifyName op) ty) }
716 ------------------------------
717 reifyType :: TypeRep.Type -> TcM TH.Type
718 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
719 reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
720 reifyType (NoteTy _ ty) = reifyType ty
721 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
722 reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
723 reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
724 ; tau' <- reifyType tau
725 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
727 (tvs, cxt, tau) = tcSplitSigmaTy ty
728 reifyTypes = mapM reifyType
729 reifyCxt = mapM reifyPred
731 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
732 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
734 reifyTyVars :: [TyVar] -> [TH.Name]
735 reifyTyVars = map reifyName
737 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
738 reify_tc_app tc tys = do { tys' <- reifyTypes tys
739 ; return (foldl TH.AppT (TH.ConT tc) tys') }
741 reifyPred :: TypeRep.PredType -> TcM TH.Type
742 reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
743 reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p)
746 ------------------------------
747 reifyName :: NamedThing n => n -> TH.Name
749 | isExternalName name = mk_varg pkg_str mod_str occ_str
750 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
751 -- Many of the things we reify have local bindings, and
752 -- NameL's aren't supposed to appear in binding positions, so
753 -- we use NameU. When/if we start to reify nested things, that
754 -- have free variables, we may need to generate NameL's for them.
757 mod = nameModule name
758 pkg_str = packageIdString (modulePackageId mod)
759 mod_str = moduleNameString (moduleName mod)
760 occ_str = occNameString occ
761 occ = nameOccName name
762 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
763 | OccName.isVarOcc occ = TH.mkNameG_v
764 | OccName.isTcOcc occ = TH.mkNameG_tc
765 | otherwise = pprPanic "reifyName" (ppr name)
767 ------------------------------
768 reifyFixity :: Name -> TcM TH.Fixity
770 = do { fix <- lookupFixityRn name
771 ; return (conv_fix fix) }
773 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
774 conv_dir BasicTypes.InfixR = TH.InfixR
775 conv_dir BasicTypes.InfixL = TH.InfixL
776 conv_dir BasicTypes.InfixN = TH.InfixN
778 reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
779 reifyStrict MarkedStrict = TH.IsStrict
780 reifyStrict MarkedUnboxed = TH.IsStrict
781 reifyStrict NotMarkedStrict = TH.NotStrict
783 ------------------------------
784 noTH :: LitString -> SDoc -> TcM a
785 noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+>
786 ptext SLIT("in Template Haskell:"),