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