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