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