Add kind equalities to GHC.
[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 ; if isOpenTypeFamilyTyCon tc
1118 then do { fam_envs <- tcGetFamInstEnvs
1119 ; instances <- reifyFamilyInstances tc
1120 (familyInstances fam_envs tc)
1121 ; return (TH.FamilyI
1122 (TH.OpenTypeFamilyD (reifyName tc) tvs'
1123 resultSig injectivity)
1124 instances) }
1125 else do { eqns <-
1126 case isClosedSynFamilyTyConWithAxiom_maybe tc of
1127 Just ax -> mapM (reifyAxBranch tc) $
1128 fromBranches $ coAxiomBranches ax
1129 Nothing -> return []
1130 ; return (TH.FamilyI
1131 (TH.ClosedTypeFamilyD (reifyName tc) tvs' resultSig
1132 injectivity eqns)
1133 []) } }
1134
1135 | isDataFamilyTyCon tc
1136 = do { let tvs = tyConTyVars tc
1137 kind = tyConKind tc
1138
1139 -- we need the *result kind* (see #8884)
1140 (kvs, mono_kind) = splitForAllTys kind
1141 -- tyConArity includes *kind* params
1142 (_, res_kind) = splitFunTysN (tyConArity tc - length kvs)
1143 mono_kind
1144 ; kind' <- fmap Just (reifyKind res_kind)
1145
1146 ; tvs' <- reifyTyVars tvs (Just tc)
1147 ; fam_envs <- tcGetFamInstEnvs
1148 ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)
1149 ; return (TH.FamilyI
1150 (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }
1151
1152 | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym
1153 = do { rhs' <- reifyType rhs
1154 ; tvs' <- reifyTyVars tvs (Just tc)
1155 ; return (TH.TyConI
1156 (TH.TySynD (reifyName tc) tvs' rhs'))
1157 }
1158
1159 | otherwise
1160 = do { cxt <- reifyCxt (tyConStupidTheta tc)
1161 ; let tvs = tyConTyVars tc
1162 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
1163 ; r_tvs <- reifyTyVars tvs (Just tc)
1164 ; let name = reifyName tc
1165 deriv = [] -- Don't know about deriving
1166 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
1167 | otherwise = TH.DataD cxt name r_tvs cons deriv
1168 ; return (TH.TyConI decl) }
1169
1170 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
1171 -- For GADTs etc, see Note [Reifying data constructors]
1172 reifyDataCon tys dc
1173 = do { let (ex_tvs, theta, arg_tys) = dataConInstSig dc tys
1174 stricts = map reifyStrict (dataConSrcBangs dc)
1175 fields = dataConFieldLabels dc
1176 name = reifyName dc
1177
1178 ; r_arg_tys <- reifyTypes arg_tys
1179
1180 ; let main_con | not (null fields)
1181 = TH.RecC name (zip3 (map (reifyName . flSelector) fields) stricts r_arg_tys)
1182 | dataConIsInfix dc
1183 = ASSERT( length arg_tys == 2 )
1184 TH.InfixC (s1,r_a1) name (s2,r_a2)
1185 | otherwise
1186 = TH.NormalC name (stricts `zip` r_arg_tys)
1187 [r_a1, r_a2] = r_arg_tys
1188 [s1, s2] = stricts
1189
1190 ; ASSERT( length arg_tys == length stricts )
1191 if null ex_tvs && null theta then
1192 return main_con
1193 else do
1194 { cxt <- reifyCxt theta
1195 ; ex_tvs' <- reifyTyVars ex_tvs Nothing
1196 ; return (TH.ForallC ex_tvs' cxt main_con) } }
1197
1198 ------------------------------
1199 reifyClass :: Class -> TcM TH.Info
1200 reifyClass cls
1201 = do { cxt <- reifyCxt theta
1202 ; inst_envs <- tcGetInstEnvs
1203 ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
1204 ; assocTys <- concatMapM reifyAT ats
1205 ; ops <- concatMapM reify_op op_stuff
1206 ; tvs' <- reifyTyVars tvs (Just $ classTyCon cls)
1207 ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
1208 ; return (TH.ClassI dec insts) }
1209 where
1210 (tvs, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
1211 fds' = map reifyFunDep fds
1212 reify_op (op, def_meth)
1213 = do { ty <- reifyType (idType op)
1214 ; let nm' = reifyName op
1215 ; case def_meth of
1216 Just (_, GenericDM gdm_ty) ->
1217 do { gdm_ty' <- reifyType gdm_ty
1218 ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty'] }
1219 _ -> return [TH.SigD nm' ty] }
1220
1221 reifyAT :: ClassATItem -> TcM [TH.Dec]
1222 reifyAT (ATI tycon def) = do
1223 tycon' <- reifyTyCon tycon
1224 case tycon' of
1225 TH.FamilyI dec _ -> do
1226 let (tyName, tyArgs) = tfNames dec
1227 (dec :) <$> maybe (return [])
1228 (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
1229 def
1230 _ -> pprPanic "reifyAT" (text (show tycon'))
1231
1232 reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
1233 reifyDefImpl n args ty =
1234 TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty
1235
1236 tfNames :: TH.Dec -> (TH.Name, [TH.Name])
1237 tfNames (TH.OpenTypeFamilyD n args _ _) = (n, map bndrName args)
1238 tfNames d = pprPanic "tfNames" (text (show d))
1239
1240 bndrName :: TH.TyVarBndr -> TH.Name
1241 bndrName (TH.PlainTV n) = n
1242 bndrName (TH.KindedTV n _) = n
1243
1244 ------------------------------
1245 -- | Annotate (with TH.SigT) a type if the first parameter is True
1246 -- and if the type contains a free variable.
1247 -- This is used to annotate type patterns for poly-kinded tyvars in
1248 -- reifying class and type instances. See #8953 and th/T8953.
1249 annotThType :: Bool -- True <=> annotate
1250 -> TyCoRep.Type -> TH.Type -> TcM TH.Type
1251 -- tiny optimization: if the type is annotated, don't annotate again.
1252 annotThType _ _ th_ty@(TH.SigT {}) = return th_ty
1253 annotThType True ty th_ty
1254 | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
1255 = do { let ki = typeKind ty
1256 ; th_ki <- reifyKind ki
1257 ; return (TH.SigT th_ty th_ki) }
1258 annotThType _ _ th_ty = return th_ty
1259
1260 -- | For every type variable in the input,
1261 -- report whether or not the tv is poly-kinded. This is used to eventually
1262 -- feed into 'annotThType'.
1263 mkIsPolyTvs :: [TyVar] -> [Bool]
1264 mkIsPolyTvs = map is_poly_tv
1265 where
1266 is_poly_tv tv = not $
1267 isEmptyVarSet $
1268 filterVarSet isTyVar $
1269 tyCoVarsOfType $
1270 tyVarKind tv
1271
1272 ------------------------------
1273 reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
1274 reifyClassInstances cls insts
1275 = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
1276 where
1277 tvs = filterOutInvisibleTyVars (classTyCon cls) (classTyVars cls)
1278
1279 reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1280 -- includes only *visible* tvs
1281 -> ClsInst -> TcM TH.Dec
1282 reifyClassInstance is_poly_tvs i
1283 = do { cxt <- reifyCxt theta
1284 ; let vis_types = filterOutInvisibleTypes cls_tc types
1285 ; thtypes <- reifyTypes vis_types
1286 ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types 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 cls_tc = classTyCon cls
1292 dfun = instanceDFunId i
1293
1294 ------------------------------
1295 reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
1296 reifyFamilyInstances fam_tc fam_insts
1297 = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
1298 where
1299 fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
1300
1301 reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1302 -- includes only *visible* tvs
1303 -> FamInst -> TcM TH.Dec
1304 reifyFamilyInstance is_poly_tvs inst@(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 = filterOutInvisibleTypes fam_tc 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 = filterOutInvisibleTypes fam_tc 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 where
1338 fam_tc = famInstTyCon inst
1339
1340 ------------------------------
1341 reifyType :: TyCoRep.Type -> TcM TH.Type
1342 -- Monadic only because of failure
1343 reifyType ty@(ForAllTy (Named _ _) _) = reify_for_all ty
1344 reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) }
1345 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1346 reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
1347 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1348 reifyType ty@(ForAllTy (Anon t1) t2)
1349 | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
1350 | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1351 reifyType ty@(CastTy {}) = noTH (sLit "kind casts") (ppr ty)
1352 reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)
1353
1354 reify_for_all :: TyCoRep.Type -> TcM TH.Type
1355 reify_for_all ty
1356 = do { cxt' <- reifyCxt cxt;
1357 ; tau' <- reifyType tau
1358 ; tvs' <- reifyTyVars tvs Nothing
1359 ; return (TH.ForallT tvs' cxt' tau') }
1360 where
1361 (tvs, cxt, tau) = tcSplitSigmaTy ty
1362
1363 reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
1364 reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
1365 reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
1366
1367 reifyTypes :: [Type] -> TcM [TH.Type]
1368 reifyTypes = mapM reifyType
1369
1370 reifyKind :: Kind -> TcM TH.Kind
1371 reifyKind ki
1372 = do { let (kis, ki') = splitFunTys ki
1373 ; ki'_rep <- reifyNonArrowKind ki'
1374 ; kis_rep <- mapM reifyKind kis
1375 ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) }
1376 where
1377 reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT
1378 | isConstraintKind k = return TH.ConstraintT
1379 reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v))
1380 reifyNonArrowKind (ForAllTy _ k) = reifyKind k
1381 reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis
1382 reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1
1383 ; k2' <- reifyKind k2
1384 ; return (TH.AppT k1' k2')
1385 }
1386 reifyNonArrowKind k = noTH (sLit "this kind") (ppr k)
1387
1388 reify_kc_app :: TyCon -> [TyCoRep.Kind] -> TcM TH.Kind
1389 reify_kc_app kc kis
1390 = fmap (mkThAppTs r_kc) (mapM reifyKind kis)
1391 where
1392 r_kc | isTupleTyCon kc = TH.TupleT (tyConArity kc)
1393 | kc `hasKey` listTyConKey = TH.ListT
1394 | otherwise = TH.ConT (reifyName kc)
1395
1396 reifyCxt :: [PredType] -> TcM [TH.Pred]
1397 reifyCxt = mapM reifyPred
1398
1399 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1400 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1401
1402 reifyTyVars :: [TyVar]
1403 -> Maybe TyCon -- the tycon if the tycovars are from a tycon.
1404 -- Used to detect which tvs are implicit.
1405 -> TcM [TH.TyVarBndr]
1406 reifyTyVars tvs m_tc = mapM reify_tv tvs'
1407 where
1408 tvs' = case m_tc of
1409 Just tc -> filterOutInvisibleTyVars tc tvs
1410 Nothing -> tvs
1411
1412 -- even if the kind is *, we need to include a kind annotation,
1413 -- in case a poly-kind would be inferred without the annotation.
1414 -- See #8953 or test th/T8953
1415 reify_tv tv = TH.KindedTV name <$> reifyKind kind
1416 where
1417 kind = tyVarKind tv
1418 name = reifyName tv
1419
1420 {-
1421 Note [Kind annotations on TyConApps]
1422 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1423 A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.
1424 For example:
1425
1426 type family F a :: k
1427 type instance F Int = (Proxy :: * -> *)
1428 type instance F Bool = (Proxy :: (* -> *) -> *)
1429
1430 It's hard to figure out where these annotations should appear, so we do this:
1431 Suppose the tycon is applied to n arguments. We strip off the first n
1432 arguments of the tycon's kind. If there are any variables left in the result
1433 kind, we put on a kind annotation. But we must be slightly careful: it's
1434 possible that the tycon's kind will have fewer than n arguments, in the case
1435 that the concrete application instantiates a result kind variable with an
1436 arrow kind. So, if we run out of arguments, we conservatively put on a kind
1437 annotation anyway. This should be a rare case, indeed. Here is an example:
1438
1439 data T1 :: k1 -> k2 -> *
1440 data T2 :: k1 -> k2 -> *
1441
1442 type family G (a :: k) :: k
1443 type instance G T1 = T2
1444
1445 type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above
1446
1447 Here G's kind is (forall k. k -> k), and the desugared RHS of that last
1448 instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
1449 the algorithm above, there are 3 arguments to G so we should peel off 3
1450 arguments in G's kind. But G's kind has only two arguments. This is the
1451 rare special case, and we conservatively choose to put the annotation
1452 in.
1453
1454 See #8953 and test th/T8953.
1455 -}
1456
1457 reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
1458 reify_tc_app tc tys
1459 = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
1460 ; maybe_sig_t (mkThAppTs r_tc tys') }
1461 where
1462 arity = tyConArity tc
1463 tc_kind = tyConKind tc
1464
1465 r_tc | isTupleTyCon tc = if isPromotedDataCon tc
1466 then TH.PromotedTupleT arity
1467 else TH.TupleT arity
1468 | tc `hasKey` listTyConKey = TH.ListT
1469 | tc `hasKey` nilDataConKey = TH.PromotedNilT
1470 | tc `hasKey` consDataConKey = TH.PromotedConsT
1471 | tc `hasKey` heqTyConKey = TH.EqualityT
1472 | tc `hasKey` eqPrimTyConKey = TH.EqualityT
1473 | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
1474 | otherwise = TH.ConT (reifyName tc)
1475
1476 -- See Note [Kind annotations on TyConApps]
1477 maybe_sig_t th_type
1478 | needs_kind_sig
1479 = do { let full_kind = typeKind (mkTyConApp tc tys)
1480 ; th_full_kind <- reifyKind full_kind
1481 ; return (TH.SigT th_type th_full_kind) }
1482 | otherwise
1483 = return th_type
1484
1485 needs_kind_sig
1486 | Just result_ki <- peel_off_n_args tc_kind (length tys)
1487 = not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType result_ki
1488 | otherwise
1489 = True
1490
1491 peel_off_n_args :: Kind -> Arity -> Maybe Kind
1492 peel_off_n_args k 0 = Just k
1493 peel_off_n_args k n
1494 | Just (_, res_k) <- splitPiTy_maybe k
1495 = peel_off_n_args res_k (n-1)
1496 | otherwise
1497 = Nothing
1498
1499 reifyPred :: TyCoRep.PredType -> TcM TH.Pred
1500 reifyPred ty
1501 -- We could reify the invisible paramter as a class but it seems
1502 -- nicer to support them properly...
1503 | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
1504 | otherwise = reifyType ty
1505
1506 ------------------------------
1507 reifyName :: NamedThing n => n -> TH.Name
1508 reifyName thing
1509 | isExternalName name = mk_varg pkg_str mod_str occ_str
1510 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1511 -- Many of the things we reify have local bindings, and
1512 -- NameL's aren't supposed to appear in binding positions, so
1513 -- we use NameU. When/if we start to reify nested things, that
1514 -- have free variables, we may need to generate NameL's for them.
1515 where
1516 name = getName thing
1517 mod = ASSERT( isExternalName name ) nameModule name
1518 pkg_str = unitIdString (moduleUnitId mod)
1519 mod_str = moduleNameString (moduleName mod)
1520 occ_str = occNameString occ
1521 occ = nameOccName name
1522 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1523 | OccName.isVarOcc occ = TH.mkNameG_v
1524 | OccName.isTcOcc occ = TH.mkNameG_tc
1525 | otherwise = pprPanic "reifyName" (ppr name)
1526
1527 ------------------------------
1528 reifyFixity :: Name -> TcM TH.Fixity
1529 reifyFixity name
1530 = do { fix <- lookupFixityRn name
1531 ; return (conv_fix fix) }
1532 where
1533 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1534 conv_dir BasicTypes.InfixR = TH.InfixR
1535 conv_dir BasicTypes.InfixL = TH.InfixL
1536 conv_dir BasicTypes.InfixN = TH.InfixN
1537
1538 reifyStrict :: DataCon.HsSrcBang -> TH.Strict
1539 reifyStrict (HsSrcBang _ _ SrcLazy) = TH.NotStrict
1540 reifyStrict (HsSrcBang _ _ NoSrcStrict) = TH.NotStrict
1541 reifyStrict (HsSrcBang _ SrcUnpack SrcStrict) = TH.Unpacked
1542 reifyStrict (HsSrcBang _ _ SrcStrict) = TH.IsStrict
1543
1544 ------------------------------
1545 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
1546 lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
1547 lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
1548 = return $ ModuleTarget $
1549 mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
1550
1551 reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
1552 reifyAnnotations th_name
1553 = do { name <- lookupThAnnLookup th_name
1554 ; topEnv <- getTopEnv
1555 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1556 ; tcg <- getGblEnv
1557 ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
1558 ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
1559 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1560
1561 ------------------------------
1562 modToTHMod :: Module -> TH.Module
1563 modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m)
1564 (TH.ModName $ moduleNameString $ moduleName m)
1565
1566 reifyModule :: TH.Module -> TcM TH.ModuleInfo
1567 reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
1568 this_mod <- getModule
1569 let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)
1570 if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
1571 where
1572 reifyThisModule = do
1573 usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
1574 return $ TH.ModuleInfo usages
1575
1576 reifyFromIface reifMod = do
1577 iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod
1578 let usages = [modToTHMod m | usage <- mi_usages iface,
1579 Just m <- [usageToModule (moduleUnitId reifMod) usage] ]
1580 return $ TH.ModuleInfo usages
1581
1582 usageToModule :: UnitId -> Usage -> Maybe Module
1583 usageToModule _ (UsageFile {}) = Nothing
1584 usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
1585 usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
1586
1587 ------------------------------
1588 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
1589 mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys
1590
1591 noTH :: LitString -> SDoc -> TcM a
1592 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1593 ptext (sLit "in Template Haskell:"),
1594 nest 2 d])
1595
1596 ppr_th :: TH.Ppr a => a -> SDoc
1597 ppr_th x = text (TH.pprint x)
1598
1599 {-
1600 Note [Reifying data constructors]
1601 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1602 Template Haskell syntax is rich enough to express even GADTs,
1603 provided we do so in the equality-predicate form. So a GADT
1604 like
1605
1606 data T a where
1607 MkT1 :: a -> T [a]
1608 MkT2 :: T Int
1609
1610 will appear in TH syntax like this
1611
1612 data T a = forall b. (a ~ [b]) => MkT1 b
1613 | (a ~ Int) => MkT2
1614 -}
1615
1616 #endif /* GHCI */