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