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