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