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