Rename package key to unit ID, and installed package ID to component ID.
[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 = unitIdString (moduleUnitId 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 ; assocTys <- concatMapM reifyAT ats
1206 ; ops <- concatMapM reify_op op_stuff
1207 ; tvs' <- reifyTyVars tvs
1208 ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
1209 ; return (TH.ClassI dec insts) }
1210 where
1211 (tvs, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
1212 fds' = map reifyFunDep fds
1213 reify_op (op, def_meth)
1214 = do { ty <- reifyType (idType op)
1215 ; let nm' = reifyName op
1216 ; case def_meth of
1217 GenDefMeth gdm_nm ->
1218 do { gdm_id <- tcLookupId gdm_nm
1219 ; gdm_ty <- reifyType (idType gdm_id)
1220 ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty] }
1221 _ -> return [TH.SigD nm' ty] }
1222
1223 reifyAT :: ClassATItem -> TcM [TH.Dec]
1224 reifyAT (ATI tycon def) = do
1225 tycon' <- reifyTyCon tycon
1226 case tycon' of
1227 TH.FamilyI dec _ -> do
1228 let (tyName, tyArgs) = tfNames dec
1229 (dec :) <$> maybe (return [])
1230 (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
1231 def
1232 _ -> pprPanic "reifyAT" (text (show tycon'))
1233
1234 reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
1235 reifyDefImpl n args ty =
1236 TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty
1237
1238 tfNames :: TH.Dec -> (TH.Name, [TH.Name])
1239 tfNames (TH.OpenTypeFamilyD n args _ _) = (n, map bndrName args)
1240 tfNames d = pprPanic "tfNames" (text (show d))
1241
1242 bndrName :: TH.TyVarBndr -> TH.Name
1243 bndrName (TH.PlainTV n) = n
1244 bndrName (TH.KindedTV n _) = n
1245
1246 ------------------------------
1247 -- | Annotate (with TH.SigT) a type if the first parameter is True
1248 -- and if the type contains a free variable.
1249 -- This is used to annotate type patterns for poly-kinded tyvars in
1250 -- reifying class and type instances. See #8953 and th/T8953.
1251 annotThType :: Bool -- True <=> annotate
1252 -> TypeRep.Type -> TH.Type -> TcM TH.Type
1253 -- tiny optimization: if the type is annotated, don't annotate again.
1254 annotThType _ _ th_ty@(TH.SigT {}) = return th_ty
1255 annotThType True ty th_ty
1256 | not $ isEmptyVarSet $ tyVarsOfType ty
1257 = do { let ki = typeKind ty
1258 ; th_ki <- reifyKind ki
1259 ; return (TH.SigT th_ty th_ki) }
1260 annotThType _ _ th_ty = return th_ty
1261
1262 -- | For every *type* variable (not *kind* variable) in the input,
1263 -- report whether or not the tv is poly-kinded. This is used to eventually
1264 -- feed into 'annotThType'.
1265 mkIsPolyTvs :: [TyVar] -> [Bool]
1266 mkIsPolyTvs tvs = [ is_poly_tv tv | tv <- tvs
1267 , not (isKindVar tv) ]
1268 where
1269 is_poly_tv tv = not $ isEmptyVarSet $ tyVarsOfType $ tyVarKind tv
1270
1271 ------------------------------
1272 reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
1273 reifyClassInstances cls insts
1274 = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
1275 where
1276 tvs = classTyVars cls
1277
1278 reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1279 -- this list contains flags only for *type*
1280 -- variables, not *kind* variables
1281 -> ClsInst -> TcM TH.Dec
1282 reifyClassInstance is_poly_tvs i
1283 = do { cxt <- reifyCxt theta
1284 ; let types_only = filterOut isKind types
1285 ; thtypes <- reifyTypes types_only
1286 ; annot_thtypes <- zipWith3M annotThType is_poly_tvs types_only thtypes
1287 ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
1288 ; return $ (TH.InstanceD cxt head_ty []) }
1289 where
1290 (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
1291 dfun = instanceDFunId i
1292
1293 ------------------------------
1294 reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
1295 reifyFamilyInstances fam_tc fam_insts
1296 = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
1297 where
1298 fam_tvs = tyConTyVars fam_tc
1299
1300 reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1301 -- this list contains flags only for *type*
1302 -- variables, not *kind* variables
1303 -> FamInst -> TcM TH.Dec
1304 reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor
1305 , fi_fam = fam
1306 , fi_tys = lhs
1307 , fi_rhs = rhs })
1308 = case flavor of
1309 SynFamilyInst ->
1310 -- remove kind patterns (#8884)
1311 do { let lhs_types_only = filterOut isKind lhs
1312 ; th_lhs <- reifyTypes lhs_types_only
1313 ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
1314 th_lhs
1315 ; th_rhs <- reifyType rhs
1316 ; return (TH.TySynInstD (reifyName fam)
1317 (TH.TySynEqn annot_th_lhs th_rhs)) }
1318
1319 DataFamilyInst rep_tc ->
1320 do { let tvs = tyConTyVars rep_tc
1321 fam' = reifyName fam
1322
1323 -- eta-expand lhs types, because sometimes data/newtype
1324 -- instances are eta-reduced; See Trac #9692
1325 -- See Note [Eta reduction for data family axioms]
1326 -- in TcInstDcls
1327 (_rep_tc, rep_tc_args) = splitTyConApp rhs
1328 etad_tyvars = dropList rep_tc_args tvs
1329 eta_expanded_lhs = lhs `chkAppend` mkTyVarTys etad_tyvars
1330 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc)
1331 ; let types_only = filterOut isKind eta_expanded_lhs
1332 ; th_tys <- reifyTypes types_only
1333 ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
1334 ; return (if isNewTyCon rep_tc
1335 then TH.NewtypeInstD [] fam' annot_th_tys (head cons) []
1336 else TH.DataInstD [] fam' annot_th_tys cons []) }
1337
1338 ------------------------------
1339 reifyType :: TypeRep.Type -> TcM TH.Type
1340 -- Monadic only because of failure
1341 reifyType ty@(ForAllTy _ _) = reify_for_all ty
1342 reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) }
1343 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1344 reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
1345 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1346 reifyType ty@(FunTy t1 t2)
1347 | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
1348 | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1349
1350 reify_for_all :: TypeRep.Type -> TcM TH.Type
1351 reify_for_all ty
1352 = do { cxt' <- reifyCxt cxt;
1353 ; tau' <- reifyType tau
1354 ; tvs' <- reifyTyVars tvs
1355 ; return (TH.ForallT tvs' cxt' tau') }
1356 where
1357 (tvs, cxt, tau) = tcSplitSigmaTy ty
1358
1359 reifyTyLit :: TypeRep.TyLit -> TcM TH.TyLit
1360 reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
1361 reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
1362
1363 reifyTypes :: [Type] -> TcM [TH.Type]
1364 reifyTypes = mapM reifyType
1365
1366 reifyKind :: Kind -> TcM TH.Kind
1367 reifyKind ki
1368 = do { let (kis, ki') = splitKindFunTys ki
1369 ; ki'_rep <- reifyNonArrowKind ki'
1370 ; kis_rep <- mapM reifyKind kis
1371 ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) }
1372 where
1373 reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT
1374 | isConstraintKind k = return TH.ConstraintT
1375 reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v))
1376 reifyNonArrowKind (ForAllTy _ k) = reifyKind k
1377 reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis
1378 reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1
1379 ; k2' <- reifyKind k2
1380 ; return (TH.AppT k1' k2')
1381 }
1382 reifyNonArrowKind k = noTH (sLit "this kind") (ppr k)
1383
1384 reify_kc_app :: TyCon -> [TypeRep.Kind] -> TcM TH.Kind
1385 reify_kc_app kc kis
1386 = fmap (mkThAppTs r_kc) (mapM reifyKind kis)
1387 where
1388 r_kc | Just tc <- isPromotedTyCon_maybe kc
1389 , isTupleTyCon tc = TH.TupleT (tyConArity kc)
1390 | kc `hasKey` listTyConKey = TH.ListT
1391 | otherwise = TH.ConT (reifyName kc)
1392
1393 reifyCxt :: [PredType] -> TcM [TH.Pred]
1394 reifyCxt = mapM reifyPred
1395
1396 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1397 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1398
1399 reifyTyVars :: [TyVar]
1400 -> TcM [TH.TyVarBndr]
1401 reifyTyVars tvs = mapM reify_tv $ filter isTypeVar tvs
1402 where
1403 -- even if the kind is *, we need to include a kind annotation,
1404 -- in case a poly-kind would be inferred without the annotation.
1405 -- See #8953 or test th/T8953
1406 reify_tv tv = TH.KindedTV name <$> reifyKind kind
1407 where
1408 kind = tyVarKind tv
1409 name = reifyName tv
1410
1411 {-
1412 Note [Kind annotations on TyConApps]
1413 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1414 A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.
1415 For example:
1416
1417 type family F a :: k
1418 type instance F Int = (Proxy :: * -> *)
1419 type instance F Bool = (Proxy :: (* -> *) -> *)
1420
1421 It's hard to figure out where these annotations should appear, so we do this:
1422 Suppose the tycon is applied to n arguments. We strip off the first n
1423 arguments of the tycon's kind. If there are any variables left in the result
1424 kind, we put on a kind annotation. But we must be slightly careful: it's
1425 possible that the tycon's kind will have fewer than n arguments, in the case
1426 that the concrete application instantiates a result kind variable with an
1427 arrow kind. So, if we run out of arguments, we conservatively put on a kind
1428 annotation anyway. This should be a rare case, indeed. Here is an example:
1429
1430 data T1 :: k1 -> k2 -> *
1431 data T2 :: k1 -> k2 -> *
1432
1433 type family G (a :: k) :: k
1434 type instance G T1 = T2
1435
1436 type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above
1437
1438 Here G's kind is (forall k. k -> k), and the desugared RHS of that last
1439 instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
1440 the algorithm above, there are 3 arguments to G so we should peel off 3
1441 arguments in G's kind. But G's kind has only two arguments. This is the
1442 rare special case, and we conservatively choose to put the annotation
1443 in.
1444
1445 See #8953 and test th/T8953.
1446 -}
1447
1448 reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type
1449 reify_tc_app tc tys
1450 = do { tys' <- reifyTypes (removeKinds tc_kind tys)
1451 ; maybe_sig_t (mkThAppTs r_tc tys') }
1452 where
1453 arity = tyConArity tc
1454 tc_kind = tyConKind tc
1455 r_tc | isTupleTyCon tc = if isPromotedDataCon tc
1456 then TH.PromotedTupleT arity
1457 else TH.TupleT arity
1458 | tc `hasKey` listTyConKey = TH.ListT
1459 | tc `hasKey` nilDataConKey = TH.PromotedNilT
1460 | tc `hasKey` consDataConKey = TH.PromotedConsT
1461 | tc `hasKey` eqTyConKey = TH.EqualityT
1462 | otherwise = TH.ConT (reifyName tc)
1463
1464 -- See Note [Kind annotations on TyConApps]
1465 maybe_sig_t th_type
1466 | needs_kind_sig
1467 = do { let full_kind = typeKind (mkTyConApp tc tys)
1468 ; th_full_kind <- reifyKind full_kind
1469 ; return (TH.SigT th_type th_full_kind) }
1470 | otherwise
1471 = return th_type
1472
1473 needs_kind_sig
1474 | Just result_ki <- peel_off_n_args tc_kind (length tys)
1475 = not $ isEmptyVarSet $ kiVarsOfKind result_ki
1476 | otherwise
1477 = True
1478
1479 peel_off_n_args :: Kind -> Arity -> Maybe Kind
1480 peel_off_n_args k 0 = Just k
1481 peel_off_n_args k n
1482 | Just (_, res_k) <- splitForAllTy_maybe k
1483 = peel_off_n_args res_k (n-1)
1484 | Just (_, res_k) <- splitFunTy_maybe k
1485 = peel_off_n_args res_k (n-1)
1486 | otherwise
1487 = Nothing
1488
1489 removeKinds :: Kind -> [TypeRep.Type] -> [TypeRep.Type]
1490 removeKinds (FunTy k1 k2) (h:t)
1491 | isSuperKind k1 = removeKinds k2 t
1492 | otherwise = h : removeKinds k2 t
1493 removeKinds (ForAllTy v k) (h:t)
1494 | isSuperKind (varType v) = removeKinds k t
1495 | otherwise = h : removeKinds k t
1496 removeKinds _ tys = tys
1497
1498 reifyPred :: TypeRep.PredType -> TcM TH.Pred
1499 reifyPred ty
1500 -- We could reify the implicit paramter as a class but it seems
1501 -- nicer to support them properly...
1502 | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
1503 | otherwise = reifyType ty
1504
1505 ------------------------------
1506 reifyName :: NamedThing n => n -> TH.Name
1507 reifyName thing
1508 | isExternalName name = mk_varg pkg_str mod_str occ_str
1509 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1510 -- Many of the things we reify have local bindings, and
1511 -- NameL's aren't supposed to appear in binding positions, so
1512 -- we use NameU. When/if we start to reify nested things, that
1513 -- have free variables, we may need to generate NameL's for them.
1514 where
1515 name = getName thing
1516 mod = ASSERT( isExternalName name ) nameModule name
1517 pkg_str = unitIdString (moduleUnitId mod)
1518 mod_str = moduleNameString (moduleName mod)
1519 occ_str = occNameString occ
1520 occ = nameOccName name
1521 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1522 | OccName.isVarOcc occ = TH.mkNameG_v
1523 | OccName.isTcOcc occ = TH.mkNameG_tc
1524 | otherwise = pprPanic "reifyName" (ppr name)
1525
1526 ------------------------------
1527 reifyFixity :: Name -> TcM TH.Fixity
1528 reifyFixity name
1529 = do { fix <- lookupFixityRn name
1530 ; return (conv_fix fix) }
1531 where
1532 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1533 conv_dir BasicTypes.InfixR = TH.InfixR
1534 conv_dir BasicTypes.InfixL = TH.InfixL
1535 conv_dir BasicTypes.InfixN = TH.InfixN
1536
1537 reifyStrict :: DataCon.HsSrcBang -> TH.Strict
1538 reifyStrict (HsSrcBang _ _ SrcLazy) = TH.NotStrict
1539 reifyStrict (HsSrcBang _ _ NoSrcStrict) = TH.NotStrict
1540 reifyStrict (HsSrcBang _ SrcUnpack SrcStrict) = TH.Unpacked
1541 reifyStrict (HsSrcBang _ _ SrcStrict) = TH.IsStrict
1542
1543 ------------------------------
1544 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
1545 lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
1546 lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
1547 = return $ ModuleTarget $
1548 mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
1549
1550 reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
1551 reifyAnnotations th_name
1552 = do { name <- lookupThAnnLookup th_name
1553 ; topEnv <- getTopEnv
1554 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1555 ; tcg <- getGblEnv
1556 ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
1557 ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
1558 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1559
1560 ------------------------------
1561 modToTHMod :: Module -> TH.Module
1562 modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m)
1563 (TH.ModName $ moduleNameString $ moduleName m)
1564
1565 reifyModule :: TH.Module -> TcM TH.ModuleInfo
1566 reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
1567 this_mod <- getModule
1568 let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)
1569 if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
1570 where
1571 reifyThisModule = do
1572 usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
1573 return $ TH.ModuleInfo usages
1574
1575 reifyFromIface reifMod = do
1576 iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod
1577 let usages = [modToTHMod m | usage <- mi_usages iface,
1578 Just m <- [usageToModule (moduleUnitId reifMod) usage] ]
1579 return $ TH.ModuleInfo usages
1580
1581 usageToModule :: UnitId -> Usage -> Maybe Module
1582 usageToModule _ (UsageFile {}) = Nothing
1583 usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
1584 usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
1585
1586 ------------------------------
1587 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
1588 mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys
1589
1590 noTH :: LitString -> SDoc -> TcM a
1591 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1592 ptext (sLit "in Template Haskell:"),
1593 nest 2 d])
1594
1595 ppr_th :: TH.Ppr a => a -> SDoc
1596 ppr_th x = text (TH.pprint x)
1597
1598 {-
1599 Note [Reifying data constructors]
1600 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1601 Template Haskell syntax is rich enough to express even GADTs,
1602 provided we do so in the equality-predicate form. So a GADT
1603 like
1604
1605 data T a where
1606 MkT1 :: a -> T [a]
1607 MkT2 :: T Int
1608
1609 will appear in TH syntax like this
1610
1611 data T a = forall b. (a ~ [b]) => MkT1 b
1612 | (a ~ Int) => MkT2
1613 -}
1614
1615 #endif /* GHCI */