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