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