Improve HsBang
[ghc.git] / compiler / typecheck / TcSplice.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 TcSplice: Template Haskell splices
7 -}
8
9 {-# LANGUAGE CPP, FlexibleInstances, MagicHash, ScopedTypeVariables #-}
10 {-# OPTIONS_GHC -fno-warn-orphans #-}
11
12 module TcSplice(
13 -- These functions are defined in stage1 and stage2
14 -- The raise civilised errors in stage1
15 tcSpliceExpr, tcTypedBracket, tcUntypedBracket,
16 runQuasiQuoteExpr, runQuasiQuotePat,
17 runQuasiQuoteDecl, runQuasiQuoteType,
18 runAnnotation,
19
20 #ifdef GHCI
21 -- These ones are defined only in stage2, and are
22 -- called only in stage2 (ie GHCI is on)
23 runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
24 tcTopSpliceExpr, lookupThName_maybe,
25 defaultRunMeta, runMeta'
26 #endif
27 ) where
28
29 #include "HsVersions.h"
30
31 import HsSyn
32 import Annotations
33 import Name
34 import TcRnMonad
35 import RdrName
36 import TcType
37
38 #ifdef GHCI
39 import HscMain
40 -- These imports are the reason that TcSplice
41 -- is very high up the module hierarchy
42
43 import HscTypes
44 import Convert
45 import RnExpr
46 import RnEnv
47 import RnTypes
48 import TcExpr
49 import TcHsSyn
50 import TcSimplify
51 import TcUnify
52 import Type
53 import Kind
54 import NameSet
55 import TcEnv
56 import TcMType
57 import TcHsType
58 import TcIface
59 import TypeRep
60 import FamInst
61 import FamInstEnv
62 import InstEnv
63 import NameEnv
64 import PrelNames
65 import OccName
66 import Hooks
67 import Var
68 import Module
69 import LoadIface
70 import Class
71 import Inst
72 import TyCon
73 import CoAxiom
74 import PatSyn ( patSynName )
75 import ConLike
76 import DataCon
77 import TcEvidence( TcEvBinds(..) )
78 import Id
79 import IdInfo
80 import DsExpr
81 import DsMonad
82 import Serialized
83 import ErrUtils
84 import SrcLoc
85 import Util
86 import Data.List ( mapAccumL )
87 import Unique
88 import VarSet ( isEmptyVarSet )
89 import Data.Maybe
90 import BasicTypes hiding( SuccessFlag(..) )
91 import Maybes( MaybeErr(..) )
92 import DynFlags
93 import Panic
94 import Lexeme
95 import FastString
96 import Outputable
97 import Control.Monad ( when )
98
99 import DsMeta
100 import qualified Language.Haskell.TH as TH
101 -- THSyntax gives access to internal functions and data types
102 import qualified Language.Haskell.TH.Syntax as TH
103
104 -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
105 import GHC.Desugar ( AnnotationWrapper(..) )
106
107 import qualified Data.Map as Map
108 import Data.Dynamic ( fromDynamic, toDyn )
109 import Data.Typeable ( typeOf )
110 import Data.Data (Data)
111 import GHC.Exts ( unsafeCoerce# )
112 #endif
113
114 {-
115 ************************************************************************
116 * *
117 \subsection{Main interface + stubs for the non-GHCI case
118 * *
119 ************************************************************************
120 -}
121
122 tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
123 tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId)
124 tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
125 -- None of these functions add constraints to the LIE
126
127 runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
128 runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName)
129 runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)
130 runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
131
132 runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
133
134 #ifndef GHCI
135 tcTypedBracket x _ = failTH x "Template Haskell bracket"
136 tcUntypedBracket x _ _ = failTH x "Template Haskell bracket"
137 tcSpliceExpr e _ = failTH e "Template Haskell splice"
138
139 runQuasiQuoteExpr q = failTH q "quasiquote"
140 runQuasiQuotePat q = failTH q "pattern quasiquote"
141 runQuasiQuoteType q = failTH q "type quasiquote"
142 runQuasiQuoteDecl q = failTH q "declaration quasiquote"
143 runAnnotation _ q = failTH q "annotation"
144
145 #else
146 -- The whole of the rest of the file is the else-branch (ie stage2 only)
147
148 {-
149 Note [How top-level splices are handled]
150 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
151 Top-level splices (those not inside a [| .. |] quotation bracket) are handled
152 very straightforwardly:
153
154 1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
155
156 2. runMetaT: desugar, compile, run it, and convert result back to
157 HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,
158 HsExpr RdrName etc)
159
160 3. treat the result as if that's what you saw in the first place
161 e.g for HsType, rename and kind-check
162 for HsExpr, rename and type-check
163
164 (The last step is different for decls, because they can *only* be
165 top-level: we return the result of step 2.)
166
167 Note [How brackets and nested splices are handled]
168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
169 Nested splices (those inside a [| .. |] quotation bracket),
170 are treated quite differently.
171
172 Remember, there are two forms of bracket
173 typed [|| e ||]
174 and untyped [| e |]
175
176 The life cycle of a typed bracket:
177 * Starts as HsBracket
178
179 * When renaming:
180 * Set the ThStage to (Brack s RnPendingTyped)
181 * Rename the body
182 * Result is still a HsBracket
183
184 * When typechecking:
185 * Set the ThStage to (Brack s (TcPending ps_var lie_var))
186 * Typecheck the body, and throw away the elaborated result
187 * Nested splices (which must be typed) are typechecked, and
188 the results accumulated in ps_var; their constraints
189 accumulate in lie_var
190 * Result is a HsTcBracketOut rn_brack pending_splices
191 where rn_brack is the incoming renamed bracket
192
193 The life cycle of a un-typed bracket:
194 * Starts as HsBracket
195
196 * When renaming:
197 * Set the ThStage to (Brack s (RnPendingUntyped ps_var))
198 * Rename the body
199 * Nested splices (which must be untyped) are renamed, and the
200 results accumulated in ps_var
201 * Result is still (HsRnBracketOut rn_body pending_splices)
202
203 * When typechecking a HsRnBracketOut
204 * Typecheck the pending_splices individually
205 * Ignore the body of the bracket; just check that the context
206 expects a bracket of that type (e.g. a [p| pat |] bracket should
207 be in a context needing a (Q Pat)
208 * Result is a HsTcBracketOut rn_brack pending_splices
209 where rn_brack is the incoming renamed bracket
210
211
212 In both cases, desugaring happens like this:
213 * HsTcBracketOut is desugared by DsMeta.dsBracket. It
214
215 a) Extends the ds_meta environment with the PendingSplices
216 attached to the bracket
217
218 b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
219 run, will produce a suitable TH expression/type/decl. This
220 is why we leave the *renamed* expression attached to the bracket:
221 the quoted expression should not be decorated with all the goop
222 added by the type checker
223
224 * Each splice carries a unique Name, called a "splice point", thus
225 ${n}(e). The name is initialised to an (Unqual "splice") when the
226 splice is created; the renamer gives it a unique.
227
228 * When DsMeta (used to desugar the body of the bracket) comes across
229 a splice, it looks up the splice's Name, n, in the ds_meta envt,
230 to find an (HsExpr Id) that should be substituted for the splice;
231 it just desugars it to get a CoreExpr (DsMeta.repSplice).
232
233 Example:
234 Source: f = [| Just $(g 3) |]
235 The [| |] part is a HsBracket
236
237 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
238 The [| |] part is a HsBracketOut, containing *renamed*
239 (not typechecked) expression
240 The "s7" is the "splice point"; the (g Int 3) part
241 is a typechecked expression
242
243 Desugared: f = do { s7 <- g Int 3
244 ; return (ConE "Data.Maybe.Just" s7) }
245
246
247 Note [Template Haskell state diagram]
248 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
249 Here are the ThStages, s, their corresponding level numbers
250 (the result of (thLevel s)), and their state transitions.
251 The top level of the program is stage Comp:
252
253 Start here
254 |
255 V
256 ----------- $ ------------ $
257 | Comp | ---------> | Splice | -----|
258 | 1 | | 0 | <----|
259 ----------- ------------
260 ^ | ^ |
261 $ | | [||] $ | | [||]
262 | v | v
263 -------------- ----------------
264 | Brack Comp | | Brack Splice |
265 | 2 | | 1 |
266 -------------- ----------------
267
268 * Normal top-level declarations start in state Comp
269 (which has level 1).
270 Annotations start in state Splice, since they are
271 treated very like a splice (only without a '$')
272
273 * Code compiled in state Splice (and only such code)
274 will be *run at compile time*, with the result replacing
275 the splice
276
277 * The original paper used level -1 instead of 0, etc.
278
279 * The original paper did not allow a splice within a
280 splice, but there is no reason not to. This is the
281 $ transition in the top right.
282
283 Note [Template Haskell levels]
284 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
285 * Imported things are impLevel (= 0)
286
287 * However things at level 0 are not *necessarily* imported.
288 eg $( \b -> ... ) here b is bound at level 0
289
290 * In GHCi, variables bound by a previous command are treated
291 as impLevel, because we have bytecode for them.
292
293 * Variables are bound at the "current level"
294
295 * The current level starts off at outerLevel (= 1)
296
297 * The level is decremented by splicing $(..)
298 incremented by brackets [| |]
299 incremented by name-quoting 'f
300
301 When a variable is used, we compare
302 bind: binding level, and
303 use: current level at usage site
304
305 Generally
306 bind > use Always error (bound later than used)
307 [| \x -> $(f x) |]
308
309 bind = use Always OK (bound same stage as used)
310 [| \x -> $(f [| x |]) |]
311
312 bind < use Inside brackets, it depends
313 Inside splice, OK
314 Inside neither, OK
315
316 For (bind < use) inside brackets, there are three cases:
317 - Imported things OK f = [| map |]
318 - Top-level things OK g = [| f |]
319 - Non-top-level Only if there is a liftable instance
320 h = \(x:Int) -> [| x |]
321
322 To track top-level-ness we use the ThBindEnv in TcLclEnv
323
324 For example:
325 f = ...
326 g1 = $(map ...) is OK
327 g2 = $(f ...) is not OK; because we havn't compiled f yet
328
329
330 ************************************************************************
331 * *
332 \subsection{Quoting an expression}
333 * *
334 ************************************************************************
335 -}
336
337 -- See Note [How brackets and nested splices are handled]
338 -- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
339 tcTypedBracket brack@(TExpBr expr) res_ty
340 = addErrCtxt (quotationCtxtDoc brack) $
341 do { cur_stage <- getStage
342 ; ps_ref <- newMutVar []
343 ; lie_var <- getConstraintVar -- Any constraints arising from nested splices
344 -- should get thrown into the constraint set
345 -- from outside the bracket
346
347 -- Typecheck expr to make sure it is valid,
348 -- Throw away the typechecked expression but return its type.
349 -- We'll typecheck it again when we splice it in somewhere
350 ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
351 tcInferRhoNC expr
352 -- NC for no context; tcBracket does that
353
354 ; meta_ty <- tcTExpTy expr_ty
355 ; co <- unifyType meta_ty res_ty
356 ; ps' <- readMutVar ps_ref
357 ; texpco <- tcLookupId unsafeTExpCoerceName
358 ; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
359 (noLoc (HsTcBracketOut brack ps'))))) }
360 tcTypedBracket other_brack _
361 = pprPanic "tcTypedBracket" (ppr other_brack)
362
363 -- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId)
364 tcUntypedBracket brack ps res_ty
365 = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
366 ; ps' <- mapM tcPendingSplice ps
367 ; meta_ty <- tcBrackTy brack
368 ; co <- unifyType meta_ty res_ty
369 ; traceTc "tc_bracket done untyped" (ppr meta_ty)
370 ; return (mkHsWrapCo co (HsTcBracketOut brack ps')) }
371
372 ---------------
373 tcBrackTy :: HsBracket Name -> TcM TcType
374 tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
375 tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp)
376 tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
377 tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
378 tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)
379 tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL"
380 tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr"
381
382 ---------------
383 tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
384 tcPendingSplice (PendingRnExpSplice (PendSplice n expr))
385 = do { res_ty <- tcMetaTy expQTyConName
386 ; tc_pending_splice n expr res_ty }
387 tcPendingSplice (PendingRnPatSplice (PendSplice n expr))
388 = do { res_ty <- tcMetaTy patQTyConName
389 ; tc_pending_splice n expr res_ty }
390 tcPendingSplice (PendingRnTypeSplice (PendSplice n expr))
391 = do { res_ty <- tcMetaTy typeQTyConName
392 ; tc_pending_splice n expr res_ty }
393 tcPendingSplice (PendingRnDeclSplice (PendSplice n expr))
394 = do { res_ty <- tcMetaTy decsQTyConName
395 ; tc_pending_splice n expr res_ty }
396
397 tcPendingSplice (PendingRnCrossStageSplice n)
398 -- Behave like $(lift x); not very pretty
399 = do { res_ty <- tcMetaTy expQTyConName
400 ; tc_pending_splice n (nlHsApp (nlHsVar liftName) (nlHsVar n)) res_ty }
401
402 ---------------
403 tc_pending_splice :: Name -> LHsExpr Name -> TcRhoType -> TcM PendingTcSplice
404 tc_pending_splice splice_name expr res_ty
405 = do { expr' <- tcMonoExpr expr res_ty
406 ; return (PendSplice splice_name expr') }
407
408 ---------------
409 -- Takes a type tau and returns the type Q (TExp tau)
410 tcTExpTy :: TcType -> TcM TcType
411 tcTExpTy tau = do
412 q <- tcLookupTyCon qTyConName
413 texp <- tcLookupTyCon tExpTyConName
414 return (mkTyConApp q [mkTyConApp texp [tau]])
415
416 {-
417 ************************************************************************
418 * *
419 \subsection{Splicing an expression}
420 * *
421 ************************************************************************
422 -}
423
424 tcSpliceExpr splice@(HsSplice name expr) res_ty
425 = addErrCtxt (spliceCtxtDoc splice) $
426 setSrcSpan (getLoc expr) $ do
427 { stage <- getStage
428 ; case stage of
429 Splice {} -> tcTopSplice expr res_ty
430 Comp -> tcTopSplice expr res_ty
431 Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty }
432
433 tcNestedSplice :: ThStage -> PendingStuff -> Name
434 -> LHsExpr Name -> TcRhoType -> TcM (HsExpr Id)
435 -- See Note [How brackets and nested splices are handled]
436 -- A splice inside brackets
437 tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty
438 = do { meta_exp_ty <- tcTExpTy res_ty
439 ; expr' <- setStage pop_stage $
440 setConstraintVar lie_var $
441 tcMonoExpr expr meta_exp_ty
442 ; untypeq <- tcLookupId unTypeQName
443 ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'
444 ; ps <- readMutVar ps_var
445 ; writeMutVar ps_var (PendSplice splice_name expr'' : ps)
446
447 -- The returned expression is ignored; it's in the pending splices
448 ; return (panic "tcSpliceExpr") }
449
450 tcNestedSplice _ _ splice_name _ _
451 = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)
452
453 tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id)
454 tcTopSplice expr res_ty
455 = do { -- Typecheck the expression,
456 -- making sure it has type Q (T res_ty)
457 meta_exp_ty <- tcTExpTy res_ty
458 ; zonked_q_expr <- tcTopSpliceExpr True $
459 tcMonoExpr expr meta_exp_ty
460
461 -- Run the expression
462 ; expr2 <- runMetaE zonked_q_expr
463 ; showSplice "expression" expr (ppr expr2)
464
465 -- Rename and typecheck the spliced-in expression,
466 -- making sure it has type res_ty
467 -- These steps should never fail; this is a *typed* splice
468 ; addErrCtxt (spliceResultDoc expr) $ do
469 { (exp3, _fvs) <- rnLExpr expr2
470 ; exp4 <- tcMonoExpr exp3 res_ty
471 ; return (unLoc exp4) } }
472
473 {-
474 ************************************************************************
475 * *
476 \subsection{Error messages}
477 * *
478 ************************************************************************
479 -}
480
481 quotationCtxtDoc :: HsBracket Name -> SDoc
482 quotationCtxtDoc br_body
483 = hang (ptext (sLit "In the Template Haskell quotation"))
484 2 (ppr br_body)
485
486 spliceCtxtDoc :: HsSplice Name -> SDoc
487 spliceCtxtDoc splice
488 = hang (ptext (sLit "In the Template Haskell splice"))
489 2 (pprTypedSplice splice)
490
491 spliceResultDoc :: LHsExpr Name -> SDoc
492 spliceResultDoc expr
493 = sep [ ptext (sLit "In the result of the splice:")
494 , nest 2 (char '$' <> pprParendExpr expr)
495 , ptext (sLit "To see what the splice expanded to, use -ddump-splices")]
496
497 -------------------
498 tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id)
499 -- Note [How top-level splices are handled]
500 -- Type check an expression that is the body of a top-level splice
501 -- (the caller will compile and run it)
502 -- Note that set the level to Splice, regardless of the original level,
503 -- before typechecking the expression. For example:
504 -- f x = $( ...$(g 3) ... )
505 -- The recursive call to tcMonoExpr will simply expand the
506 -- inner escape before dealing with the outer one
507
508 tcTopSpliceExpr isTypedSplice tc_action
509 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
510 -- if the type checker fails!
511 unsetGOptM Opt_DeferTypeErrors $
512 -- Don't defer type errors. Not only are we
513 -- going to run this code, but we do an unsafe
514 -- coerce, so we get a seg-fault if, say we
515 -- splice a type into a place where an expression
516 -- is expected (Trac #7276)
517 setStage (Splice isTypedSplice) $
518 do { -- Typecheck the expression
519 (expr', lie) <- captureConstraints tc_action
520
521 -- Solve the constraints
522 ; const_binds <- simplifyTop lie
523
524 -- Zonk it and tie the knot of dictionary bindings
525 ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') }
526
527 {-
528 ************************************************************************
529 * *
530 Annotations
531 * *
532 ************************************************************************
533 -}
534
535 runAnnotation target expr = do
536 -- Find the classes we want instances for in order to call toAnnotationWrapper
537 loc <- getSrcSpanM
538 data_class <- tcLookupClass dataClassName
539 to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
540
541 -- Check the instances we require live in another module (we want to execute it..)
542 -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
543 -- also resolves the LIE constraints to detect e.g. instance ambiguity
544 zonked_wrapped_expr' <- tcTopSpliceExpr False $
545 do { (expr', expr_ty) <- tcInferRhoNC expr
546 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
547 -- By instantiating the call >here< it gets registered in the
548 -- LIE consulted by tcTopSpliceExpr
549 -- and hence ensures the appropriate dictionary is bound by const_binds
550 ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
551 ; let specialised_to_annotation_wrapper_expr
552 = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
553 ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
554
555 -- Run the appropriately wrapped expression to get the value of
556 -- the annotation and its dictionaries. The return value is of
557 -- type AnnotationWrapper by construction, so this conversion is
558 -- safe
559 serialized <- runMetaAW zonked_wrapped_expr'
560 return Annotation {
561 ann_target = target,
562 ann_value = serialized
563 }
564
565 convertAnnotationWrapper :: AnnotationWrapper -> Either MsgDoc Serialized
566 convertAnnotationWrapper annotation_wrapper = Right $
567 case annotation_wrapper of
568 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
569 -- Got the value and dictionaries: build the serialized value and
570 -- call it a day. We ensure that we seq the entire serialized value
571 -- in order that any errors in the user-written code for the
572 -- annotation are exposed at this point. This is also why we are
573 -- doing all this stuff inside the context of runMeta: it has the
574 -- facilities to deal with user error in a meta-level expression
575 seqSerialized serialized `seq` serialized
576
577
578 {-
579 ************************************************************************
580 * *
581 Quasi-quoting
582 * *
583 ************************************************************************
584
585 Note [Quasi-quote overview]
586 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
587 The GHC "quasi-quote" extension is described by Geoff Mainland's paper
588 "Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
589 Workshop 2007).
590
591 Briefly, one writes
592 [p| stuff |]
593 and the arbitrary string "stuff" gets parsed by the parser 'p', whose
594 type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
595 defined in another module, because we are going to run it here. It's
596 a bit like a TH splice:
597 $(p "stuff")
598
599 However, you can do this in patterns as well as terms. Because of this,
600 the splice is run by the *renamer* rather than the type checker.
601
602 ************************************************************************
603 * *
604 \subsubsection{Quasiquotation}
605 * *
606 ************************************************************************
607
608 See Note [Quasi-quote overview] in TcSplice.
609 -}
610
611 runQuasiQuote :: Outputable hs_syn
612 => HsQuasiQuote RdrName -- Contains term of type QuasiQuoter, and the String
613 -> Name -- Of type QuasiQuoter -> String -> Q th_syn
614 -> Name -- Name of th_syn type
615 -> String -- Description of splice type
616 -> (MetaHook RnM -> LHsExpr Id -> RnM hs_syn)
617 -> RnM hs_syn
618 runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty descr meta_req
619 = do { -- Drop the leading "$" from the quoter name, if present
620 -- This is old-style syntax, now deprecated
621 -- NB: when removing this backward-compat, remove
622 -- the matching code in Lexer.x (around line 310)
623 let occ_str = occNameString (rdrNameOcc quoter)
624 ; quoter <- ASSERT( not (null occ_str) ) -- Lexer ensures this
625 if head occ_str /= '$' then return quoter
626 else do { addWarn (deprecatedDollar quoter)
627 ; return (mkRdrUnqual (mkVarOcc (tail occ_str))) }
628
629 ; quoter' <- lookupOccRn quoter
630 -- We use lookupOcc rather than lookupGlobalOcc because in the
631 -- erroneous case of \x -> [x| ...|] we get a better error message
632 -- (stage restriction rather than out of scope).
633
634 ; when (isUnboundName quoter') failM
635 -- If 'quoter' is not in scope, proceed no further
636 -- The error message was generated by lookupOccRn, but it then
637 -- succeeds with an "unbound name", which makes the subsequent
638 -- attempt to run the quote fail in a confusing way
639
640 -- Check that the quoter is not locally defined, otherwise the TH
641 -- machinery will not be able to run the quasiquote.
642 ; this_mod <- getModule
643 ; let is_local = nameIsLocalOrFrom this_mod quoter'
644 ; checkTc (not is_local) (quoteStageError quoter')
645
646 ; traceTc "runQQ" (ppr quoter <+> ppr is_local)
647 ; HsQuasiQuote quoter'' _ quote' <- getHooked runQuasiQuoteHook return >>=
648 ($ HsQuasiQuote quoter' q_span quote)
649
650 -- Build the expression
651 ; let quoterExpr = L q_span $! HsVar $! quoter''
652 ; let quoteExpr = L q_span $! HsLit $! HsString "" quote'
653 ; let expr = L q_span $
654 HsApp (L q_span $
655 HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
656 ; meta_exp_ty <- tcMetaTy meta_ty
657
658 -- Typecheck the expression
659 ; zonked_q_expr <- tcTopSpliceExpr False (tcMonoExpr expr meta_exp_ty)
660
661 -- Run the expression
662 ; result <- runMeta meta_req zonked_q_expr
663 ; showSplice descr quoteExpr (ppr result)
664
665 ; return result }
666
667 runQuasiQuoteExpr qq
668 = runQuasiQuote qq quoteExpName expQTyConName "expression" metaRequestE
669 runQuasiQuotePat qq
670 = runQuasiQuote qq quotePatName patQTyConName "pattern" metaRequestP
671 runQuasiQuoteType qq
672 = runQuasiQuote qq quoteTypeName typeQTyConName "type" metaRequestT
673 runQuasiQuoteDecl qq
674 = runQuasiQuote qq quoteDecName decsQTyConName "declarations" metaRequestD
675
676 quoteStageError :: Name -> SDoc
677 quoteStageError quoter
678 = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
679 nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
680
681 deprecatedDollar :: RdrName -> SDoc
682 deprecatedDollar quoter
683 = hang (ptext (sLit "Deprecated syntax:"))
684 2 (ptext (sLit "quasiquotes no longer need a dollar sign:")
685 <+> ppr quoter)
686
687 {-
688 ************************************************************************
689 * *
690 \subsection{Running an expression}
691 * *
692 ************************************************************************
693 -}
694
695 runQuasi :: TH.Q a -> TcM a
696 runQuasi act = TH.runQ act
697
698 runQResult :: (a -> String) -> (SrcSpan -> a -> b) -> SrcSpan -> TH.Q a -> TcM b
699 runQResult show_th f expr_span hval
700 = do { th_result <- TH.runQ hval
701 ; traceTc "Got TH result:" (text (show_th th_result))
702 ; return (f expr_span th_result) }
703
704 -----------------
705 runMeta :: (MetaHook TcM -> LHsExpr Id -> TcM hs_syn)
706 -> LHsExpr Id
707 -> TcM hs_syn
708 runMeta unwrap e
709 = do { h <- getHooked runMetaHook defaultRunMeta
710 ; unwrap h e }
711
712 defaultRunMeta :: MetaHook TcM
713 defaultRunMeta (MetaE r)
714 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr)
715 defaultRunMeta (MetaP r)
716 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat)
717 defaultRunMeta (MetaT r)
718 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType)
719 defaultRunMeta (MetaD r)
720 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls)
721 defaultRunMeta (MetaAW r)
722 = fmap r . runMeta' False (const empty) (const (return . convertAnnotationWrapper))
723 -- We turn off showing the code in meta-level exceptions because doing so exposes
724 -- the toAnnotationWrapper function that we slap around the users code
725
726 ----------------
727 runMetaAW :: LHsExpr Id -- Of type AnnotationWrapper
728 -> TcM Serialized
729 runMetaAW = runMeta metaRequestAW
730
731 runMetaE :: LHsExpr Id -- Of type (Q Exp)
732 -> TcM (LHsExpr RdrName)
733 runMetaE = runMeta metaRequestE
734
735 runMetaP :: LHsExpr Id -- Of type (Q Pat)
736 -> TcM (LPat RdrName)
737 runMetaP = runMeta metaRequestP
738
739 runMetaT :: LHsExpr Id -- Of type (Q Type)
740 -> TcM (LHsType RdrName)
741 runMetaT = runMeta metaRequestT
742
743 runMetaD :: LHsExpr Id -- Of type Q [Dec]
744 -> TcM [LHsDecl RdrName]
745 runMetaD = runMeta metaRequestD
746
747 ---------------
748 runMeta' :: Bool -- Whether code should be printed in the exception message
749 -> (hs_syn -> SDoc) -- how to print the code
750 -> (SrcSpan -> x -> TcM (Either MsgDoc hs_syn)) -- How to run x
751 -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that
752 -> TcM hs_syn -- Of type t
753 runMeta' show_code ppr_hs run_and_convert expr
754 = do { traceTc "About to run" (ppr expr)
755 ; recordThSpliceUse -- seems to be the best place to do this,
756 -- we catch all kinds of splices and annotations.
757
758 -- Check that we've had no errors of any sort so far.
759 -- For example, if we found an error in an earlier defn f, but
760 -- recovered giving it type f :: forall a.a, it'd be very dodgy
761 -- to carry ont. Mind you, the staging restrictions mean we won't
762 -- actually run f, but it still seems wrong. And, more concretely,
763 -- see Trac #5358 for an example that fell over when trying to
764 -- reify a function with a "?" kind in it. (These don't occur
765 -- in type-correct programs.
766 ; failIfErrsM
767
768 -- Desugar
769 ; ds_expr <- initDsTc (dsLExpr expr)
770 -- Compile and link it; might fail if linking fails
771 ; hsc_env <- getTopEnv
772 ; src_span <- getSrcSpanM
773 ; traceTc "About to run (desugared)" (ppr ds_expr)
774 ; either_hval <- tryM $ liftIO $
775 HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
776 ; case either_hval of {
777 Left exn -> fail_with_exn "compile and link" exn ;
778 Right hval -> do
779
780 { -- Coerce it to Q t, and run it
781
782 -- Running might fail if it throws an exception of any kind (hence tryAllM)
783 -- including, say, a pattern-match exception in the code we are running
784 --
785 -- We also do the TH -> HS syntax conversion inside the same
786 -- exception-cacthing thing so that if there are any lurking
787 -- exceptions in the data structure returned by hval, we'll
788 -- encounter them inside the try
789 --
790 -- See Note [Exceptions in TH]
791 let expr_span = getLoc expr
792 ; either_tval <- tryAllM $
793 setSrcSpan expr_span $ -- Set the span so that qLocation can
794 -- see where this splice is
795 do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
796 ; case mb_result of
797 Left err -> failWithTc err
798 Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
799 ; return $! result } }
800
801 ; case either_tval of
802 Right v -> return v
803 Left se -> case fromException se of
804 Just IOEnvFailure -> failM -- Error already in Tc monad
805 _ -> fail_with_exn "run" se -- Exception
806 }}}
807 where
808 -- see Note [Concealed TH exceptions]
809 fail_with_exn phase exn = do
810 exn_msg <- liftIO $ Panic.safeShowException exn
811 let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
812 nest 2 (text exn_msg),
813 if show_code then text "Code:" <+> ppr expr else empty]
814 failWithTc msg
815
816 {-
817 Note [Exceptions in TH]
818 ~~~~~~~~~~~~~~~~~~~~~~~
819 Supppose we have something like this
820 $( f 4 )
821 where
822 f :: Int -> Q [Dec]
823 f n | n>3 = fail "Too many declarations"
824 | otherwise = ...
825
826 The 'fail' is a user-generated failure, and should be displayed as a
827 perfectly ordinary compiler error message, not a panic or anything
828 like that. Here's how it's processed:
829
830 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
831 effectively transforms (fail s) to
832 qReport True s >> fail
833 where 'qReport' comes from the Quasi class and fail from its monad
834 superclass.
835
836 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
837 (qReport True s) by using addErr to add an error message to the bag of errors.
838 The 'fail' in TcM raises an IOEnvFailure exception
839
840 * 'qReport' forces the message to ensure any exception hidden in unevaluated
841 thunk doesn't get into the bag of errors. Otherwise the following splice
842 will triger panic (Trac #8987):
843 $(fail undefined)
844 See also Note [Concealed TH exceptions]
845
846 * So, when running a splice, we catch all exceptions; then for
847 - an IOEnvFailure exception, we assume the error is already
848 in the error-bag (above)
849 - other errors, we add an error to the bag
850 and then fail
851
852 Note [Concealed TH exceptions]
853 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
854 When displaying the error message contained in an exception originated from TH
855 code, we need to make sure that the error message itself does not contain an
856 exception. For example, when executing the following splice:
857
858 $( error ("foo " ++ error "bar") )
859
860 the message for the outer exception is a thunk which will throw the inner
861 exception when evaluated.
862
863 For this reason, we display the message of a TH exception using the
864 'safeShowException' function, which recursively catches any exception thrown
865 when showing an error message.
866
867
868 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
869 -}
870
871 instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
872 qNewName s = do { u <- newUnique
873 ; let i = getKey u
874 ; return (TH.mkNameU s i) }
875
876 -- 'msg' is forced to ensure exceptions don't escape,
877 -- see Note [Exceptions in TH]
878 qReport True msg = seqList msg $ addErr (text msg)
879 qReport False msg = seqList msg $ addWarn (text msg)
880
881 qLocation = do { m <- getModule
882 ; l <- getSrcSpanM
883 ; r <- case l of
884 UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
885 (ppr l)
886 RealSrcSpan s -> return s
887 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
888 , TH.loc_module = moduleNameString (moduleName m)
889 , TH.loc_package = packageKeyString (modulePackageKey m)
890 , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
891 , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
892
893 qLookupName = lookupName
894 qReify = reify
895 qReifyInstances = reifyInstances
896 qReifyRoles = reifyRoles
897 qReifyAnnotations = reifyAnnotations
898 qReifyModule = reifyModule
899
900 -- For qRecover, discard error messages if
901 -- the recovery action is chosen. Otherwise
902 -- we'll only fail higher up. c.f. tryTcLIE_
903 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
904 ; case mb_res of
905 Just val -> do { addMessages msgs -- There might be warnings
906 ; return val }
907 Nothing -> recover -- Discard all msgs
908 }
909
910 qRunIO io = liftIO io
911
912 qAddDependentFile fp = do
913 ref <- fmap tcg_dependent_files getGblEnv
914 dep_files <- readTcRef ref
915 writeTcRef ref (fp:dep_files)
916
917 qAddTopDecls thds = do
918 l <- getSrcSpanM
919 let either_hval = convertToHsDecls l thds
920 ds <- case either_hval of
921 Left exn -> pprPanic "qAddTopDecls: can't convert top-level declarations" exn
922 Right ds -> return ds
923 mapM_ (checkTopDecl . unLoc) ds
924 th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
925 updTcRef th_topdecls_var (\topds -> ds ++ topds)
926 where
927 checkTopDecl :: HsDecl RdrName -> TcM ()
928 checkTopDecl (ValD binds)
929 = mapM_ bindName (collectHsBindBinders binds)
930 checkTopDecl (SigD _)
931 = return ()
932 checkTopDecl (ForD (ForeignImport (L _ name) _ _ _))
933 = bindName name
934 checkTopDecl _
935 = addErr $ text "Only function, value, and foreign import declarations may be added with addTopDecl"
936
937 bindName :: RdrName -> TcM ()
938 bindName (Exact n)
939 = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
940 ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
941 }
942
943 bindName name =
944 addErr $
945 hang (ptext (sLit "The binder") <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))
946 2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
947
948 qAddModFinalizer fin = do
949 th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
950 updTcRef th_modfinalizers_var (\fins -> fin:fins)
951
952 qGetQ = do
953 th_state_var <- fmap tcg_th_state getGblEnv
954 th_state <- readTcRef th_state_var
955 let x = Map.lookup (typeOf x) th_state >>= fromDynamic
956 return x
957
958 qPutQ x = do
959 th_state_var <- fmap tcg_th_state getGblEnv
960 updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
961
962 {-
963 ************************************************************************
964 * *
965 \subsection{Errors and contexts}
966 * *
967 ************************************************************************
968 -}
969
970 showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
971 -- Note that 'before' is *renamed* but not *typechecked*
972 -- Reason (a) less typechecking crap
973 -- (b) data constructors after type checking have been
974 -- changed to their *wrappers*, and that makes them
975 -- print always fully qualified
976 showSplice what before after
977 = do { loc <- getSrcSpanM
978 ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
979 nest 2 (sep [nest 2 (ppr before),
980 text "======>",
981 nest 2 after])]) }
982
983 {-
984 ************************************************************************
985 * *
986 Instance Testing
987 * *
988 ************************************************************************
989 -}
990
991 reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
992 reifyInstances th_nm th_tys
993 = addErrCtxt (ptext (sLit "In the argument of reifyInstances:")
994 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
995 do { loc <- getSrcSpanM
996 ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)
997 -- #9262 says to bring vars into scope, like in HsForAllTy case
998 -- of rnHsTyKi
999 ; let (kvs, tvs) = extractHsTyRdrTyVars rdr_ty
1000 tv_bndrs = userHsTyVarBndrs loc tvs
1001 hs_tvbs = mkHsQTvs tv_bndrs
1002 -- Rename to HsType Name
1003 ; ((rn_tvbs, rn_ty), _fvs)
1004 <- bindHsTyVars doc Nothing kvs hs_tvbs $ \ rn_tvbs ->
1005 do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
1006 ; return ((rn_tvbs, rn_ty), fvs) }
1007 ; (ty, _kind) <- tcHsTyVarBndrs rn_tvbs $ \ _tvs ->
1008 tcLHsType rn_ty
1009 ; ty <- zonkTcTypeToType emptyZonkEnv ty
1010 -- Substitute out the meta type variables
1011 -- In particular, the type might have kind
1012 -- variables inside it (Trac #7477)
1013
1014 ; traceTc "reifyInstances" (ppr ty $$ ppr (typeKind ty))
1015 ; case splitTyConApp_maybe ty of -- This expands any type synonyms
1016 Just (tc, tys) -- See Trac #7910
1017 | Just cls <- tyConClass_maybe tc
1018 -> do { inst_envs <- tcGetInstEnvs
1019 ; let (matches, unifies, _) = lookupInstEnv inst_envs cls tys
1020 ; traceTc "reifyInstances1" (ppr matches)
1021 ; reifyClassInstances cls (map fst matches ++ unifies) }
1022 | isOpenFamilyTyCon tc
1023 -> do { inst_envs <- tcGetFamInstEnvs
1024 ; let matches = lookupFamInstEnv inst_envs tc tys
1025 ; traceTc "reifyInstances2" (ppr matches)
1026 ; reifyFamilyInstances tc (map fim_instance matches) }
1027 _ -> bale_out (hang (ptext (sLit "reifyInstances:") <+> quotes (ppr ty))
1028 2 (ptext (sLit "is not a class constraint or type family application"))) }
1029 where
1030 doc = ClassInstanceCtx
1031 bale_out msg = failWithTc msg
1032
1033 cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName)
1034 cvt loc th_ty = case convertToHsType loc th_ty of
1035 Left msg -> failWithTc msg
1036 Right ty -> return ty
1037
1038 {-
1039 ************************************************************************
1040 * *
1041 Reification
1042 * *
1043 ************************************************************************
1044 -}
1045
1046 lookupName :: Bool -- True <=> type namespace
1047 -- False <=> value namespace
1048 -> String -> TcM (Maybe TH.Name)
1049 lookupName is_type_name s
1050 = do { lcl_env <- getLocalRdrEnv
1051 ; case lookupLocalRdrEnv lcl_env rdr_name of
1052 Just n -> return (Just (reifyName n))
1053 Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name
1054 ; return (fmap reifyName mb_nm) } }
1055 where
1056 th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M'
1057
1058 occ_fs :: FastString
1059 occ_fs = mkFastString (TH.nameBase th_name)
1060
1061 occ :: OccName
1062 occ | is_type_name
1063 = if isLexCon occ_fs then mkTcOccFS occ_fs
1064 else mkTyVarOccFS occ_fs
1065 | otherwise
1066 = if isLexCon occ_fs then mkDataOccFS occ_fs
1067 else mkVarOccFS occ_fs
1068
1069 rdr_name = case TH.nameModule th_name of
1070 Nothing -> mkRdrUnqual occ
1071 Just mod -> mkRdrQual (mkModuleName mod) occ
1072
1073 getThing :: TH.Name -> TcM TcTyThing
1074 getThing th_name
1075 = do { name <- lookupThName th_name
1076 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
1077 ; tcLookupTh name }
1078 -- ToDo: this tcLookup could fail, which would give a
1079 -- rather unhelpful error message
1080 where
1081 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
1082 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
1083 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
1084 ppr_ns _ = panic "reify/ppr_ns"
1085
1086 reify :: TH.Name -> TcM TH.Info
1087 reify th_name
1088 = do { thing <- getThing th_name
1089 ; reifyThing thing }
1090
1091 lookupThName :: TH.Name -> TcM Name
1092 lookupThName th_name = do
1093 mb_name <- lookupThName_maybe th_name
1094 case mb_name of
1095 Nothing -> failWithTc (notInScope th_name)
1096 Just name -> return name
1097
1098 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
1099 lookupThName_maybe th_name
1100 = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
1101 -- Pick the first that works
1102 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
1103 ; return (listToMaybe names) }
1104 where
1105 lookup rdr_name
1106 = do { -- Repeat much of lookupOccRn, becase we want
1107 -- to report errors in a TH-relevant way
1108 ; rdr_env <- getLocalRdrEnv
1109 ; case lookupLocalRdrEnv rdr_env rdr_name of
1110 Just name -> return (Just name)
1111 Nothing -> lookupGlobalOccRn_maybe rdr_name }
1112
1113 tcLookupTh :: Name -> TcM TcTyThing
1114 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
1115 -- it gives a reify-related error message on failure, whereas in the normal
1116 -- tcLookup, failure is a bug.
1117 tcLookupTh name
1118 = do { (gbl_env, lcl_env) <- getEnvs
1119 ; case lookupNameEnv (tcl_env lcl_env) name of {
1120 Just thing -> return thing;
1121 Nothing ->
1122
1123 case lookupNameEnv (tcg_type_env gbl_env) name of {
1124 Just thing -> return (AGlobal thing);
1125 Nothing ->
1126
1127 if nameIsLocalOrFrom (tcg_mod gbl_env) name
1128 then -- It's defined in this module
1129 failWithTc (notInEnv name)
1130
1131 else
1132 do { mb_thing <- tcLookupImported_maybe name
1133 ; case mb_thing of
1134 Succeeded thing -> return (AGlobal thing)
1135 Failed msg -> failWithTc msg
1136 }}}}
1137
1138 notInScope :: TH.Name -> SDoc
1139 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
1140 ptext (sLit "is not in scope at a reify")
1141 -- Ugh! Rather an indirect way to display the name
1142
1143 notInEnv :: Name -> SDoc
1144 notInEnv name = quotes (ppr name) <+>
1145 ptext (sLit "is not in the type environment at a reify")
1146
1147 ------------------------------
1148 reifyRoles :: TH.Name -> TcM [TH.Role]
1149 reifyRoles th_name
1150 = do { thing <- getThing th_name
1151 ; case thing of
1152 AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
1153 _ -> failWithTc (ptext (sLit "No roles associated with") <+> (ppr thing))
1154 }
1155 where
1156 reify_role Nominal = TH.NominalR
1157 reify_role Representational = TH.RepresentationalR
1158 reify_role Phantom = TH.PhantomR
1159
1160 ------------------------------
1161 reifyThing :: TcTyThing -> TcM TH.Info
1162 -- The only reason this is monadic is for error reporting,
1163 -- which in turn is mainly for the case when TH can't express
1164 -- some random GHC extension
1165
1166 reifyThing (AGlobal (AnId id))
1167 = do { ty <- reifyType (idType id)
1168 ; fix <- reifyFixity (idName id)
1169 ; let v = reifyName id
1170 ; case idDetails id of
1171 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
1172 _ -> return (TH.VarI v ty Nothing fix)
1173 }
1174
1175 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
1176 reifyThing (AGlobal (AConLike (RealDataCon dc)))
1177 = do { let name = dataConName dc
1178 ; ty <- reifyType (idType (dataConWrapId dc))
1179 ; fix <- reifyFixity name
1180 ; return (TH.DataConI (reifyName name) ty
1181 (reifyName (dataConOrigTyCon dc)) fix)
1182 }
1183 reifyThing (AGlobal (AConLike (PatSynCon ps)))
1184 = noTH (sLit "pattern synonyms") (ppr $ patSynName ps)
1185
1186 reifyThing (ATcId {tct_id = id})
1187 = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
1188 -- though it may be incomplete
1189 ; ty2 <- reifyType ty1
1190 ; fix <- reifyFixity (idName id)
1191 ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
1192
1193 reifyThing (ATyVar tv tv1)
1194 = do { ty1 <- zonkTcTyVar tv1
1195 ; ty2 <- reifyType ty1
1196 ; return (TH.TyVarI (reifyName tv) ty2) }
1197
1198 reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
1199
1200 -------------------------------------------
1201 reifyAxBranch :: CoAxBranch -> TcM TH.TySynEqn
1202 reifyAxBranch (CoAxBranch { cab_lhs = args, cab_rhs = rhs })
1203 -- remove kind patterns (#8884)
1204 = do { args' <- mapM reifyType (filter (not . isKind) args)
1205 ; rhs' <- reifyType rhs
1206 ; return (TH.TySynEqn args' rhs') }
1207
1208 reifyTyCon :: TyCon -> TcM TH.Info
1209 reifyTyCon tc
1210 | Just cls <- tyConClass_maybe tc
1211 = reifyClass cls
1212
1213 | isFunTyCon tc
1214 = return (TH.PrimTyConI (reifyName tc) 2 False)
1215
1216 | isPrimTyCon tc
1217 = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
1218
1219 | isFamilyTyCon tc
1220 = do { let tvs = tyConTyVars tc
1221 kind = tyConKind tc
1222
1223 -- we need the *result kind* (see #8884)
1224 (kvs, mono_kind) = splitForAllTys kind
1225 -- tyConArity includes *kind* params
1226 (_, res_kind) = splitKindFunTysN (tyConArity tc - length kvs)
1227 mono_kind
1228 ; kind' <- fmap Just (reifyKind res_kind)
1229
1230 ; tvs' <- reifyTyVars tvs
1231 ; flav' <- reifyFamFlavour tc
1232 ; case flav' of
1233 { Left flav -> -- open type/data family
1234 do { fam_envs <- tcGetFamInstEnvs
1235 ; instances <- reifyFamilyInstances tc
1236 (familyInstances fam_envs tc)
1237 ; return (TH.FamilyI
1238 (TH.FamilyD flav (reifyName tc) tvs' kind')
1239 instances) }
1240 ; Right eqns -> -- closed type family
1241 return (TH.FamilyI
1242 (TH.ClosedTypeFamilyD (reifyName tc) tvs' kind' eqns)
1243 []) } }
1244
1245 | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym
1246 = do { rhs' <- reifyType rhs
1247 ; tvs' <- reifyTyVars tvs
1248 ; return (TH.TyConI
1249 (TH.TySynD (reifyName tc) tvs' rhs'))
1250 }
1251
1252 | otherwise
1253 = do { cxt <- reifyCxt (tyConStupidTheta tc)
1254 ; let tvs = tyConTyVars tc
1255 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
1256 ; r_tvs <- reifyTyVars tvs
1257 ; let name = reifyName tc
1258 deriv = [] -- Don't know about deriving
1259 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
1260 | otherwise = TH.DataD cxt name r_tvs cons deriv
1261 ; return (TH.TyConI decl) }
1262
1263 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
1264 -- For GADTs etc, see Note [Reifying data constructors]
1265 reifyDataCon tys dc
1266 = do { let (tvs, theta, arg_tys, _) = dataConSig dc
1267 subst = mkTopTvSubst (tvs `zip` tys) -- Dicard ex_tvs
1268 (subst', ex_tvs') = mapAccumL substTyVarBndr subst (dropList tys tvs)
1269 theta' = substTheta subst' theta
1270 arg_tys' = substTys subst' arg_tys
1271 stricts = map reifyStrict (dataConSrcBangs dc)
1272 fields = dataConFieldLabels dc
1273 name = reifyName dc
1274
1275 ; r_arg_tys <- reifyTypes arg_tys'
1276
1277 ; let main_con | not (null fields)
1278 = TH.RecC name (zip3 (map reifyName fields) stricts r_arg_tys)
1279 | dataConIsInfix dc
1280 = ASSERT( length arg_tys == 2 )
1281 TH.InfixC (s1,r_a1) name (s2,r_a2)
1282 | otherwise
1283 = TH.NormalC name (stricts `zip` r_arg_tys)
1284 [r_a1, r_a2] = r_arg_tys
1285 [s1, s2] = stricts
1286
1287 ; ASSERT( length arg_tys == length stricts )
1288 if null ex_tvs' && null theta then
1289 return main_con
1290 else do
1291 { cxt <- reifyCxt theta'
1292 ; ex_tvs'' <- reifyTyVars ex_tvs'
1293 ; return (TH.ForallC ex_tvs'' cxt main_con) } }
1294
1295 ------------------------------
1296 reifyClass :: Class -> TcM TH.Info
1297 reifyClass cls
1298 = do { cxt <- reifyCxt theta
1299 ; inst_envs <- tcGetInstEnvs
1300 ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
1301 ; ops <- concatMapM reify_op op_stuff
1302 ; tvs' <- reifyTyVars tvs
1303 ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops
1304 ; return (TH.ClassI dec insts ) }
1305 where
1306 (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
1307 fds' = map reifyFunDep fds
1308 reify_op (op, def_meth)
1309 = do { ty <- reifyType (idType op)
1310 ; let nm' = reifyName op
1311 ; case def_meth of
1312 GenDefMeth gdm_nm ->
1313 do { gdm_id <- tcLookupId gdm_nm
1314 ; gdm_ty <- reifyType (idType gdm_id)
1315 ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty] }
1316 _ -> return [TH.SigD nm' ty] }
1317
1318 ------------------------------
1319 -- | Annotate (with TH.SigT) a type if the first parameter is True
1320 -- and if the type contains a free variable.
1321 -- This is used to annotate type patterns for poly-kinded tyvars in
1322 -- reifying class and type instances. See #8953 and th/T8953.
1323 annotThType :: Bool -- True <=> annotate
1324 -> TypeRep.Type -> TH.Type -> TcM TH.Type
1325 -- tiny optimization: if the type is annotated, don't annotate again.
1326 annotThType _ _ th_ty@(TH.SigT {}) = return th_ty
1327 annotThType True ty th_ty
1328 | not $ isEmptyVarSet $ tyVarsOfType ty
1329 = do { let ki = typeKind ty
1330 ; th_ki <- reifyKind ki
1331 ; return (TH.SigT th_ty th_ki) }
1332 annotThType _ _ th_ty = return th_ty
1333
1334 -- | For every *type* variable (not *kind* variable) in the input,
1335 -- report whether or not the tv is poly-kinded. This is used to eventually
1336 -- feed into 'annotThType'.
1337 mkIsPolyTvs :: [TyVar] -> [Bool]
1338 mkIsPolyTvs tvs = [ is_poly_tv tv | tv <- tvs
1339 , not (isKindVar tv) ]
1340 where
1341 is_poly_tv tv = not $ isEmptyVarSet $ tyVarsOfType $ tyVarKind tv
1342
1343 ------------------------------
1344 reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
1345 reifyClassInstances cls insts
1346 = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
1347 where
1348 tvs = classTyVars cls
1349
1350 reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1351 -- this list contains flags only for *type*
1352 -- variables, not *kind* variables
1353 -> ClsInst -> TcM TH.Dec
1354 reifyClassInstance is_poly_tvs i
1355 = do { cxt <- reifyCxt theta
1356 ; let types_only = filterOut isKind types
1357 ; thtypes <- reifyTypes types_only
1358 ; annot_thtypes <- zipWith3M annotThType is_poly_tvs types_only thtypes
1359 ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
1360 ; return $ (TH.InstanceD cxt head_ty []) }
1361 where
1362 (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
1363 dfun = instanceDFunId i
1364
1365 ------------------------------
1366 reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
1367 reifyFamilyInstances fam_tc fam_insts
1368 = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
1369 where
1370 fam_tvs = tyConTyVars fam_tc
1371
1372 reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1373 -- this list contains flags only for *type*
1374 -- variables, not *kind* variables
1375 -> FamInst -> TcM TH.Dec
1376 reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor
1377 , fi_fam = fam
1378 , fi_tys = lhs
1379 , fi_rhs = rhs })
1380 = case flavor of
1381 SynFamilyInst ->
1382 -- remove kind patterns (#8884)
1383 do { let lhs_types_only = filterOut isKind lhs
1384 ; th_lhs <- reifyTypes lhs_types_only
1385 ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
1386 th_lhs
1387 ; th_rhs <- reifyType rhs
1388 ; return (TH.TySynInstD (reifyName fam)
1389 (TH.TySynEqn annot_th_lhs th_rhs)) }
1390
1391 DataFamilyInst rep_tc ->
1392 do { let tvs = tyConTyVars rep_tc
1393 fam' = reifyName fam
1394
1395 -- eta-expand lhs types, because sometimes data/newtype
1396 -- instances are eta-reduced; See Trac #9692
1397 -- See Note [Eta reduction for data family axioms]
1398 -- in TcInstDcls
1399 (_rep_tc, rep_tc_args) = splitTyConApp rhs
1400 etad_tyvars = dropList rep_tc_args tvs
1401 eta_expanded_lhs = lhs `chkAppend` mkTyVarTys etad_tyvars
1402 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc)
1403 ; let types_only = filterOut isKind eta_expanded_lhs
1404 ; th_tys <- reifyTypes types_only
1405 ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
1406 ; return (if isNewTyCon rep_tc
1407 then TH.NewtypeInstD [] fam' annot_th_tys (head cons) []
1408 else TH.DataInstD [] fam' annot_th_tys cons []) }
1409
1410 ------------------------------
1411 reifyType :: TypeRep.Type -> TcM TH.Type
1412 -- Monadic only because of failure
1413 reifyType ty@(ForAllTy _ _) = reify_for_all ty
1414 reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) }
1415 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1416 reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
1417 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1418 reifyType ty@(FunTy t1 t2)
1419 | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
1420 | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1421
1422 reify_for_all :: TypeRep.Type -> TcM TH.Type
1423 reify_for_all ty
1424 = do { cxt' <- reifyCxt cxt;
1425 ; tau' <- reifyType tau
1426 ; tvs' <- reifyTyVars tvs
1427 ; return (TH.ForallT tvs' cxt' tau') }
1428 where
1429 (tvs, cxt, tau) = tcSplitSigmaTy ty
1430
1431 reifyTyLit :: TypeRep.TyLit -> TcM TH.TyLit
1432 reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
1433 reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
1434
1435 reifyTypes :: [Type] -> TcM [TH.Type]
1436 reifyTypes = mapM reifyType
1437
1438 reifyKind :: Kind -> TcM TH.Kind
1439 reifyKind ki
1440 = do { let (kis, ki') = splitKindFunTys ki
1441 ; ki'_rep <- reifyNonArrowKind ki'
1442 ; kis_rep <- mapM reifyKind kis
1443 ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) }
1444 where
1445 reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT
1446 | isConstraintKind k = return TH.ConstraintT
1447 reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v))
1448 reifyNonArrowKind (ForAllTy _ k) = reifyKind k
1449 reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis
1450 reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1
1451 ; k2' <- reifyKind k2
1452 ; return (TH.AppT k1' k2')
1453 }
1454 reifyNonArrowKind k = noTH (sLit "this kind") (ppr k)
1455
1456 reify_kc_app :: TyCon -> [TypeRep.Kind] -> TcM TH.Kind
1457 reify_kc_app kc kis
1458 = fmap (mkThAppTs r_kc) (mapM reifyKind kis)
1459 where
1460 r_kc | Just tc <- isPromotedTyCon_maybe kc
1461 , isTupleTyCon tc = TH.TupleT (tyConArity kc)
1462 | kc `hasKey` listTyConKey = TH.ListT
1463 | otherwise = TH.ConT (reifyName kc)
1464
1465 reifyCxt :: [PredType] -> TcM [TH.Pred]
1466 reifyCxt = mapM reifyPred
1467
1468 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1469 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1470
1471 reifyFamFlavour :: TyCon -> TcM (Either TH.FamFlavour [TH.TySynEqn])
1472 reifyFamFlavour tc
1473 | isOpenTypeFamilyTyCon tc = return $ Left TH.TypeFam
1474 | isDataFamilyTyCon tc = return $ Left TH.DataFam
1475
1476 -- this doesn't really handle abstract closed families, but let's not worry
1477 -- about that now
1478 | Just ax <- isClosedSynFamilyTyCon_maybe tc
1479 = do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax
1480 ; return $ Right eqns }
1481
1482 | otherwise
1483 = panic "TcSplice.reifyFamFlavour: not a type family"
1484
1485 reifyTyVars :: [TyVar]
1486 -> TcM [TH.TyVarBndr]
1487 reifyTyVars tvs = mapM reify_tv $ filter isTypeVar tvs
1488 where
1489 -- even if the kind is *, we need to include a kind annotation,
1490 -- in case a poly-kind would be inferred without the annotation.
1491 -- See #8953 or test th/T8953
1492 reify_tv tv = TH.KindedTV name <$> reifyKind kind
1493 where
1494 kind = tyVarKind tv
1495 name = reifyName tv
1496
1497 {-
1498 Note [Kind annotations on TyConApps]
1499 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1500 A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.
1501 For example:
1502
1503 type family F a :: k
1504 type instance F Int = (Proxy :: * -> *)
1505 type instance F Bool = (Proxy :: (* -> *) -> *)
1506
1507 It's hard to figure out where these annotations should appear, so we do this:
1508 Suppose the tycon is applied to n arguments. We strip off the first n
1509 arguments of the tycon's kind. If there are any variables left in the result
1510 kind, we put on a kind annotation. But we must be slightly careful: it's
1511 possible that the tycon's kind will have fewer than n arguments, in the case
1512 that the concrete application instantiates a result kind variable with an
1513 arrow kind. So, if we run out of arguments, we conservatively put on a kind
1514 annotation anyway. This should be a rare case, indeed. Here is an example:
1515
1516 data T1 :: k1 -> k2 -> *
1517 data T2 :: k1 -> k2 -> *
1518
1519 type family G (a :: k) :: k
1520 type instance G T1 = T2
1521
1522 type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above
1523
1524 Here G's kind is (forall k. k -> k), and the desugared RHS of that last
1525 instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
1526 the algoritm above, there are 3 arguments to G so we should peel off 3
1527 arguments in G's kind. But G's kind has only two arguments. This is the
1528 rare special case, and we conservatively choose to put the annotation
1529 in.
1530
1531 See #8953 and test th/T8953.
1532 -}
1533
1534 reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type
1535 reify_tc_app tc tys
1536 = do { tys' <- reifyTypes (removeKinds tc_kind tys)
1537 ; maybe_sig_t (mkThAppTs r_tc tys') }
1538 where
1539 arity = tyConArity tc
1540 tc_kind = tyConKind tc
1541 r_tc | isTupleTyCon tc = if isPromotedDataCon tc
1542 then TH.PromotedTupleT arity
1543 else TH.TupleT arity
1544 | tc `hasKey` listTyConKey = TH.ListT
1545 | tc `hasKey` nilDataConKey = TH.PromotedNilT
1546 | tc `hasKey` consDataConKey = TH.PromotedConsT
1547 | tc `hasKey` eqTyConKey = TH.EqualityT
1548 | otherwise = TH.ConT (reifyName tc)
1549
1550 -- See Note [Kind annotations on TyConApps]
1551 maybe_sig_t th_type
1552 | needs_kind_sig
1553 = do { let full_kind = typeKind (mkTyConApp tc tys)
1554 ; th_full_kind <- reifyKind full_kind
1555 ; return (TH.SigT th_type th_full_kind) }
1556 | otherwise
1557 = return th_type
1558
1559 needs_kind_sig
1560 | Just result_ki <- peel_off_n_args tc_kind (length tys)
1561 = not $ isEmptyVarSet $ kiVarsOfKind result_ki
1562 | otherwise
1563 = True
1564
1565 peel_off_n_args :: Kind -> Arity -> Maybe Kind
1566 peel_off_n_args k 0 = Just k
1567 peel_off_n_args k n
1568 | Just (_, res_k) <- splitForAllTy_maybe k
1569 = peel_off_n_args res_k (n-1)
1570 | Just (_, res_k) <- splitFunTy_maybe k
1571 = peel_off_n_args res_k (n-1)
1572 | otherwise
1573 = Nothing
1574
1575 removeKinds :: Kind -> [TypeRep.Type] -> [TypeRep.Type]
1576 removeKinds (FunTy k1 k2) (h:t)
1577 | isSuperKind k1 = removeKinds k2 t
1578 | otherwise = h : removeKinds k2 t
1579 removeKinds (ForAllTy v k) (h:t)
1580 | isSuperKind (varType v) = removeKinds k t
1581 | otherwise = h : removeKinds k t
1582 removeKinds _ tys = tys
1583
1584 reifyPred :: TypeRep.PredType -> TcM TH.Pred
1585 reifyPred ty
1586 -- We could reify the implicit paramter as a class but it seems
1587 -- nicer to support them properly...
1588 | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
1589 | otherwise = reifyType ty
1590
1591 ------------------------------
1592 reifyName :: NamedThing n => n -> TH.Name
1593 reifyName thing
1594 | isExternalName name = mk_varg pkg_str mod_str occ_str
1595 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1596 -- Many of the things we reify have local bindings, and
1597 -- NameL's aren't supposed to appear in binding positions, so
1598 -- we use NameU. When/if we start to reify nested things, that
1599 -- have free variables, we may need to generate NameL's for them.
1600 where
1601 name = getName thing
1602 mod = ASSERT( isExternalName name ) nameModule name
1603 pkg_str = packageKeyString (modulePackageKey mod)
1604 mod_str = moduleNameString (moduleName mod)
1605 occ_str = occNameString occ
1606 occ = nameOccName name
1607 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1608 | OccName.isVarOcc occ = TH.mkNameG_v
1609 | OccName.isTcOcc occ = TH.mkNameG_tc
1610 | otherwise = pprPanic "reifyName" (ppr name)
1611
1612 ------------------------------
1613 reifyFixity :: Name -> TcM TH.Fixity
1614 reifyFixity name
1615 = do { fix <- lookupFixityRn name
1616 ; return (conv_fix fix) }
1617 where
1618 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1619 conv_dir BasicTypes.InfixR = TH.InfixR
1620 conv_dir BasicTypes.InfixL = TH.InfixL
1621 conv_dir BasicTypes.InfixN = TH.InfixN
1622
1623 reifyStrict :: DataCon.HsSrcBang -> TH.Strict
1624 reifyStrict HsNoBang = TH.NotStrict
1625 reifyStrict (HsSrcBang _ False) = TH.NotStrict
1626 reifyStrict (HsSrcBang (Just True) True) = TH.Unpacked
1627 reifyStrict (HsSrcBang _ True) = TH.IsStrict
1628 reifyStrict HsStrict = TH.IsStrict
1629 reifyStrict (HsUnpack {}) = TH.Unpacked
1630
1631 ------------------------------
1632 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
1633 lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
1634 lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
1635 = return $ ModuleTarget $
1636 mkModule (stringToPackageKey $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
1637
1638 reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
1639 reifyAnnotations th_name
1640 = do { name <- lookupThAnnLookup th_name
1641 ; topEnv <- getTopEnv
1642 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1643 ; tcg <- getGblEnv
1644 ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
1645 ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
1646 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1647
1648 ------------------------------
1649 modToTHMod :: Module -> TH.Module
1650 modToTHMod m = TH.Module (TH.PkgName $ packageKeyString $ modulePackageKey m)
1651 (TH.ModName $ moduleNameString $ moduleName m)
1652
1653 reifyModule :: TH.Module -> TcM TH.ModuleInfo
1654 reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
1655 this_mod <- getModule
1656 let reifMod = mkModule (stringToPackageKey pkgString) (mkModuleName mString)
1657 if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
1658 where
1659 reifyThisModule = do
1660 usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
1661 return $ TH.ModuleInfo usages
1662
1663 reifyFromIface reifMod = do
1664 iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod
1665 let usages = [modToTHMod m | usage <- mi_usages iface,
1666 Just m <- [usageToModule (modulePackageKey reifMod) usage] ]
1667 return $ TH.ModuleInfo usages
1668
1669 usageToModule :: PackageKey -> Usage -> Maybe Module
1670 usageToModule _ (UsageFile {}) = Nothing
1671 usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
1672 usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
1673
1674 ------------------------------
1675 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
1676 mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys
1677
1678 noTH :: LitString -> SDoc -> TcM a
1679 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1680 ptext (sLit "in Template Haskell:"),
1681 nest 2 d])
1682
1683 ppr_th :: TH.Ppr a => a -> SDoc
1684 ppr_th x = text (TH.pprint x)
1685
1686 {-
1687 Note [Reifying data constructors]
1688 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1689 Template Haskell syntax is rich enough to express even GADTs,
1690 provided we do so in the equality-predicate form. So a GADT
1691 like
1692
1693 data T a where
1694 MkT1 :: a -> T [a]
1695 MkT2 :: T Int
1696
1697 will appear in TH syntax like this
1698
1699 data T a = forall b. (a ~ [b]) => MkT1 b
1700 | (a ~ Int) => MkT2
1701 -}
1702
1703 #endif /* GHCI */