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