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