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