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