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