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