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