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