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