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