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