e5090a074e10edb72f037d67747942f1adc5775f
[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 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
1317 ; r_tvs <- reifyTyVars tvs (Just tc)
1318 ; let name = reifyName tc
1319 deriv = [] -- Don't know about deriving
1320 decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
1321 | otherwise = TH.DataD cxt name r_tvs cons deriv
1322 ; return (TH.TyConI decl) }
1323
1324 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
1325 -- For GADTs etc, see Note [Reifying data constructors]
1326 reifyDataCon tys dc
1327 = do { let (ex_tvs, theta, arg_tys) = dataConInstSig dc tys
1328 stricts = map reifyStrict (dataConSrcBangs dc)
1329 fields = dataConFieldLabels dc
1330 name = reifyName dc
1331
1332 ; r_arg_tys <- reifyTypes arg_tys
1333
1334 ; let main_con | not (null fields)
1335 = TH.RecC name
1336 (zip3 (map reifyFieldLabel fields) stricts r_arg_tys)
1337 | dataConIsInfix dc
1338 = ASSERT( length arg_tys == 2 )
1339 TH.InfixC (s1,r_a1) name (s2,r_a2)
1340 | otherwise
1341 = TH.NormalC name (stricts `zip` r_arg_tys)
1342 [r_a1, r_a2] = r_arg_tys
1343 [s1, s2] = stricts
1344
1345 ; ASSERT( length arg_tys == length stricts )
1346 if null ex_tvs && null theta then
1347 return main_con
1348 else do
1349 { cxt <- reifyCxt theta
1350 ; ex_tvs' <- reifyTyVars ex_tvs Nothing
1351 ; return (TH.ForallC ex_tvs' cxt main_con) } }
1352
1353 ------------------------------
1354 reifyClass :: Class -> TcM TH.Info
1355 reifyClass cls
1356 = do { cxt <- reifyCxt theta
1357 ; inst_envs <- tcGetInstEnvs
1358 ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
1359 ; assocTys <- concatMapM reifyAT ats
1360 ; ops <- concatMapM reify_op op_stuff
1361 ; tvs' <- reifyTyVars tvs (Just $ classTyCon cls)
1362 ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
1363 ; return (TH.ClassI dec insts) }
1364 where
1365 (tvs, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
1366 fds' = map reifyFunDep fds
1367 reify_op (op, def_meth)
1368 = do { ty <- reifyType (idType op)
1369 ; let nm' = reifyName op
1370 ; case def_meth of
1371 Just (_, GenericDM gdm_ty) ->
1372 do { gdm_ty' <- reifyType gdm_ty
1373 ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty'] }
1374 _ -> return [TH.SigD nm' ty] }
1375
1376 reifyAT :: ClassATItem -> TcM [TH.Dec]
1377 reifyAT (ATI tycon def) = do
1378 tycon' <- reifyTyCon tycon
1379 case tycon' of
1380 TH.FamilyI dec _ -> do
1381 let (tyName, tyArgs) = tfNames dec
1382 (dec :) <$> maybe (return [])
1383 (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
1384 def
1385 _ -> pprPanic "reifyAT" (text (show tycon'))
1386
1387 reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
1388 reifyDefImpl n args ty =
1389 TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty
1390
1391 tfNames :: TH.Dec -> (TH.Name, [TH.Name])
1392 tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
1393 = (n, map bndrName args)
1394 tfNames d = pprPanic "tfNames" (text (show d))
1395
1396 bndrName :: TH.TyVarBndr -> TH.Name
1397 bndrName (TH.PlainTV n) = n
1398 bndrName (TH.KindedTV n _) = n
1399
1400 ------------------------------
1401 -- | Annotate (with TH.SigT) a type if the first parameter is True
1402 -- and if the type contains a free variable.
1403 -- This is used to annotate type patterns for poly-kinded tyvars in
1404 -- reifying class and type instances. See #8953 and th/T8953.
1405 annotThType :: Bool -- True <=> annotate
1406 -> TyCoRep.Type -> TH.Type -> TcM TH.Type
1407 -- tiny optimization: if the type is annotated, don't annotate again.
1408 annotThType _ _ th_ty@(TH.SigT {}) = return th_ty
1409 annotThType True ty th_ty
1410 | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
1411 = do { let ki = typeKind ty
1412 ; th_ki <- reifyKind ki
1413 ; return (TH.SigT th_ty th_ki) }
1414 annotThType _ _ th_ty = return th_ty
1415
1416 -- | For every type variable in the input,
1417 -- report whether or not the tv is poly-kinded. This is used to eventually
1418 -- feed into 'annotThType'.
1419 mkIsPolyTvs :: [TyVar] -> [Bool]
1420 mkIsPolyTvs = map is_poly_tv
1421 where
1422 is_poly_tv tv = not $
1423 isEmptyVarSet $
1424 filterVarSet isTyVar $
1425 tyCoVarsOfType $
1426 tyVarKind tv
1427
1428 ------------------------------
1429 reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
1430 reifyClassInstances cls insts
1431 = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
1432 where
1433 tvs = filterOutInvisibleTyVars (classTyCon cls) (classTyVars cls)
1434
1435 reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1436 -- includes only *visible* tvs
1437 -> ClsInst -> TcM TH.Dec
1438 reifyClassInstance is_poly_tvs i
1439 = do { cxt <- reifyCxt theta
1440 ; let vis_types = filterOutInvisibleTypes cls_tc types
1441 ; thtypes <- reifyTypes vis_types
1442 ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
1443 ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
1444 ; return $ (TH.InstanceD cxt head_ty []) }
1445 where
1446 (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
1447 cls_tc = classTyCon cls
1448 dfun = instanceDFunId i
1449
1450 ------------------------------
1451 reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
1452 reifyFamilyInstances fam_tc fam_insts
1453 = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
1454 where
1455 fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
1456
1457 reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1458 -- includes only *visible* tvs
1459 -> FamInst -> TcM TH.Dec
1460 reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
1461 , fi_fam = fam
1462 , fi_tys = lhs
1463 , fi_rhs = rhs })
1464 = case flavor of
1465 SynFamilyInst ->
1466 -- remove kind patterns (#8884)
1467 do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
1468 ; th_lhs <- reifyTypes lhs_types_only
1469 ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
1470 th_lhs
1471 ; th_rhs <- reifyType rhs
1472 ; return (TH.TySynInstD (reifyName fam)
1473 (TH.TySynEqn annot_th_lhs th_rhs)) }
1474
1475 DataFamilyInst rep_tc ->
1476 do { let tvs = tyConTyVars rep_tc
1477 fam' = reifyName fam
1478
1479 -- eta-expand lhs types, because sometimes data/newtype
1480 -- instances are eta-reduced; See Trac #9692
1481 -- See Note [Eta reduction for data family axioms]
1482 -- in TcInstDcls
1483 (_rep_tc, rep_tc_args) = splitTyConApp rhs
1484 etad_tyvars = dropList rep_tc_args tvs
1485 eta_expanded_lhs = lhs `chkAppend` mkTyVarTys etad_tyvars
1486 ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc)
1487 ; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs
1488 ; th_tys <- reifyTypes types_only
1489 ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
1490 ; return (if isNewTyCon rep_tc
1491 then TH.NewtypeInstD [] fam' annot_th_tys (head cons) []
1492 else TH.DataInstD [] fam' annot_th_tys cons []) }
1493 where
1494 fam_tc = famInstTyCon inst
1495
1496 ------------------------------
1497 reifyType :: TyCoRep.Type -> TcM TH.Type
1498 -- Monadic only because of failure
1499 reifyType ty@(ForAllTy (Named _ _) _) = reify_for_all ty
1500 reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) }
1501 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1502 reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
1503 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1504 reifyType ty@(ForAllTy (Anon t1) t2)
1505 | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
1506 | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1507 reifyType ty@(CastTy {}) = noTH (sLit "kind casts") (ppr ty)
1508 reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)
1509
1510 reify_for_all :: TyCoRep.Type -> TcM TH.Type
1511 reify_for_all ty
1512 = do { cxt' <- reifyCxt cxt;
1513 ; tau' <- reifyType tau
1514 ; tvs' <- reifyTyVars tvs Nothing
1515 ; return (TH.ForallT tvs' cxt' tau') }
1516 where
1517 (tvs, cxt, tau) = tcSplitSigmaTy ty
1518
1519 reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
1520 reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
1521 reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
1522
1523 reifyTypes :: [Type] -> TcM [TH.Type]
1524 reifyTypes = mapM reifyType
1525
1526 reifyKind :: Kind -> TcM TH.Kind
1527 reifyKind ki
1528 = do { let (kis, ki') = splitFunTys ki
1529 ; ki'_rep <- reifyNonArrowKind ki'
1530 ; kis_rep <- mapM reifyKind kis
1531 ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) }
1532 where
1533 reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT
1534 | isConstraintKind k = return TH.ConstraintT
1535 reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v))
1536 reifyNonArrowKind (ForAllTy _ k) = reifyKind k
1537 reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis
1538 reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1
1539 ; k2' <- reifyKind k2
1540 ; return (TH.AppT k1' k2')
1541 }
1542 reifyNonArrowKind k = noTH (sLit "this kind") (ppr k)
1543
1544 reify_kc_app :: TyCon -> [TyCoRep.Kind] -> TcM TH.Kind
1545 reify_kc_app kc kis
1546 = fmap (mkThAppTs r_kc) (mapM reifyKind kis)
1547 where
1548 r_kc | isTupleTyCon kc = TH.TupleT (tyConArity kc)
1549 | kc `hasKey` listTyConKey = TH.ListT
1550 | otherwise = TH.ConT (reifyName kc)
1551
1552 reifyCxt :: [PredType] -> TcM [TH.Pred]
1553 reifyCxt = mapM reifyPred
1554
1555 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1556 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1557
1558 reifyTyVars :: [TyVar]
1559 -> Maybe TyCon -- the tycon if the tycovars are from a tycon.
1560 -- Used to detect which tvs are implicit.
1561 -> TcM [TH.TyVarBndr]
1562 reifyTyVars tvs m_tc = mapM reify_tv tvs'
1563 where
1564 tvs' = case m_tc of
1565 Just tc -> filterOutInvisibleTyVars tc tvs
1566 Nothing -> tvs
1567
1568 -- even if the kind is *, we need to include a kind annotation,
1569 -- in case a poly-kind would be inferred without the annotation.
1570 -- See #8953 or test th/T8953
1571 reify_tv tv = TH.KindedTV name <$> reifyKind kind
1572 where
1573 kind = tyVarKind tv
1574 name = reifyName tv
1575
1576 {-
1577 Note [Kind annotations on TyConApps]
1578 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1579 A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.
1580 For example:
1581
1582 type family F a :: k
1583 type instance F Int = (Proxy :: * -> *)
1584 type instance F Bool = (Proxy :: (* -> *) -> *)
1585
1586 It's hard to figure out where these annotations should appear, so we do this:
1587 Suppose the tycon is applied to n arguments. We strip off the first n
1588 arguments of the tycon's kind. If there are any variables left in the result
1589 kind, we put on a kind annotation. But we must be slightly careful: it's
1590 possible that the tycon's kind will have fewer than n arguments, in the case
1591 that the concrete application instantiates a result kind variable with an
1592 arrow kind. So, if we run out of arguments, we conservatively put on a kind
1593 annotation anyway. This should be a rare case, indeed. Here is an example:
1594
1595 data T1 :: k1 -> k2 -> *
1596 data T2 :: k1 -> k2 -> *
1597
1598 type family G (a :: k) :: k
1599 type instance G T1 = T2
1600
1601 type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above
1602
1603 Here G's kind is (forall k. k -> k), and the desugared RHS of that last
1604 instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
1605 the algorithm above, there are 3 arguments to G so we should peel off 3
1606 arguments in G's kind. But G's kind has only two arguments. This is the
1607 rare special case, and we conservatively choose to put the annotation
1608 in.
1609
1610 See #8953 and test th/T8953.
1611 -}
1612
1613 reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
1614 reify_tc_app tc tys
1615 = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
1616 ; maybe_sig_t (mkThAppTs r_tc tys') }
1617 where
1618 arity = tyConArity tc
1619 tc_kind = tyConKind tc
1620
1621 r_tc | isTupleTyCon tc = if isPromotedDataCon tc
1622 then TH.PromotedTupleT arity
1623 else TH.TupleT arity
1624 | tc `hasKey` listTyConKey = TH.ListT
1625 | tc `hasKey` nilDataConKey = TH.PromotedNilT
1626 | tc `hasKey` consDataConKey = TH.PromotedConsT
1627 | tc `hasKey` heqTyConKey = TH.EqualityT
1628 | tc `hasKey` eqPrimTyConKey = TH.EqualityT
1629 | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
1630 | otherwise = TH.ConT (reifyName tc)
1631
1632 -- See Note [Kind annotations on TyConApps]
1633 maybe_sig_t th_type
1634 | needs_kind_sig
1635 = do { let full_kind = typeKind (mkTyConApp tc tys)
1636 ; th_full_kind <- reifyKind full_kind
1637 ; return (TH.SigT th_type th_full_kind) }
1638 | otherwise
1639 = return th_type
1640
1641 needs_kind_sig
1642 | Just result_ki <- peel_off_n_args tc_kind (length tys)
1643 = not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType result_ki
1644 | otherwise
1645 = True
1646
1647 peel_off_n_args :: Kind -> Arity -> Maybe Kind
1648 peel_off_n_args k 0 = Just k
1649 peel_off_n_args k n
1650 | Just (_, res_k) <- splitPiTy_maybe k
1651 = peel_off_n_args res_k (n-1)
1652 | otherwise
1653 = Nothing
1654
1655 reifyPred :: TyCoRep.PredType -> TcM TH.Pred
1656 reifyPred ty
1657 -- We could reify the invisible paramter as a class but it seems
1658 -- nicer to support them properly...
1659 | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
1660 | otherwise = reifyType ty
1661
1662 ------------------------------
1663 reifyName :: NamedThing n => n -> TH.Name
1664 reifyName thing
1665 | isExternalName name = mk_varg pkg_str mod_str occ_str
1666 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1667 -- Many of the things we reify have local bindings, and
1668 -- NameL's aren't supposed to appear in binding positions, so
1669 -- we use NameU. When/if we start to reify nested things, that
1670 -- have free variables, we may need to generate NameL's for them.
1671 where
1672 name = getName thing
1673 mod = ASSERT( isExternalName name ) nameModule name
1674 pkg_str = unitIdString (moduleUnitId mod)
1675 mod_str = moduleNameString (moduleName mod)
1676 occ_str = occNameString occ
1677 occ = nameOccName name
1678 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1679 | OccName.isVarOcc occ = TH.mkNameG_v
1680 | OccName.isTcOcc occ = TH.mkNameG_tc
1681 | otherwise = pprPanic "reifyName" (ppr name)
1682
1683 -- See Note [Reifying field labels]
1684 reifyFieldLabel :: FieldLabel -> TH.Name
1685 reifyFieldLabel fl
1686 | flIsOverloaded fl
1687 = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))
1688 | otherwise = TH.mkNameG_v pkg_str mod_str occ_str
1689 where
1690 name = flSelector fl
1691 mod = ASSERT( isExternalName name ) nameModule name
1692 pkg_str = unitIdString (moduleUnitId mod)
1693 mod_str = moduleNameString (moduleName mod)
1694 occ_str = unpackFS (flLabel fl)
1695
1696 reifySelector :: Id -> TyCon -> TH.Name
1697 reifySelector id tc
1698 = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of
1699 Just fl -> reifyFieldLabel fl
1700 Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
1701
1702 ------------------------------
1703 reifyFixity :: Name -> TcM TH.Fixity
1704 reifyFixity name
1705 = do { fix <- lookupFixityRn name
1706 ; return (conv_fix fix) }
1707 where
1708 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1709 conv_dir BasicTypes.InfixR = TH.InfixR
1710 conv_dir BasicTypes.InfixL = TH.InfixL
1711 conv_dir BasicTypes.InfixN = TH.InfixN
1712
1713 reifyStrict :: DataCon.HsSrcBang -> TH.Strict
1714 reifyStrict (HsSrcBang _ _ SrcLazy) = TH.NotStrict
1715 reifyStrict (HsSrcBang _ _ NoSrcStrict) = TH.NotStrict
1716 reifyStrict (HsSrcBang _ SrcUnpack SrcStrict) = TH.Unpacked
1717 reifyStrict (HsSrcBang _ _ SrcStrict) = TH.IsStrict
1718
1719 ------------------------------
1720 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
1721 lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
1722 lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
1723 = return $ ModuleTarget $
1724 mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
1725
1726 reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
1727 reifyAnnotations th_name
1728 = do { name <- lookupThAnnLookup th_name
1729 ; topEnv <- getTopEnv
1730 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1731 ; tcg <- getGblEnv
1732 ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
1733 ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
1734 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1735
1736 ------------------------------
1737 modToTHMod :: Module -> TH.Module
1738 modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m)
1739 (TH.ModName $ moduleNameString $ moduleName m)
1740
1741 reifyModule :: TH.Module -> TcM TH.ModuleInfo
1742 reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
1743 this_mod <- getModule
1744 let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)
1745 if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
1746 where
1747 reifyThisModule = do
1748 usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
1749 return $ TH.ModuleInfo usages
1750
1751 reifyFromIface reifMod = do
1752 iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod
1753 let usages = [modToTHMod m | usage <- mi_usages iface,
1754 Just m <- [usageToModule (moduleUnitId reifMod) usage] ]
1755 return $ TH.ModuleInfo usages
1756
1757 usageToModule :: UnitId -> Usage -> Maybe Module
1758 usageToModule _ (UsageFile {}) = Nothing
1759 usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
1760 usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
1761
1762 ------------------------------
1763 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
1764 mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys
1765
1766 noTH :: LitString -> SDoc -> TcM a
1767 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1768 ptext (sLit "in Template Haskell:"),
1769 nest 2 d])
1770
1771 ppr_th :: TH.Ppr a => a -> SDoc
1772 ppr_th x = text (TH.pprint x)
1773
1774 {-
1775 Note [Reifying data constructors]
1776 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1777 Template Haskell syntax is rich enough to express even GADTs,
1778 provided we do so in the equality-predicate form. So a GADT
1779 like
1780
1781 data T a where
1782 MkT1 :: a -> T [a]
1783 MkT2 :: T Int
1784
1785 will appear in TH syntax like this
1786
1787 data T a = forall b. (a ~ [b]) => MkT1 b
1788 | (a ~ Int) => MkT2
1789
1790 Note [Reifying field labels]
1791 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1792 When reifying a datatype declared with DuplicateRecordFields enabled, we want
1793 the reified names of the fields to be labels rather than selector functions.
1794 That is, we want (reify ''T) and (reify 'foo) to produce
1795
1796 data T = MkT { foo :: Int }
1797 foo :: T -> Int
1798
1799 rather than
1800
1801 data T = MkT { $sel:foo:MkT :: Int }
1802 $sel:foo:MkT :: T -> Int
1803
1804 because otherwise TH code that uses the field names as strings will silently do
1805 the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather
1806 than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the
1807 environment, NameG can't be used to represent such fields. Instead,
1808 reifyFieldLabel uses NameQ.
1809
1810 However, this means that extracting the field name from the output of reify, and
1811 trying to reify it again, may fail with an ambiguity error if there are multiple
1812 such fields defined in the module (see the test case
1813 overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to
1814 the TH AST to make it able to represent duplicate record fields.
1815 -}
1816
1817 #endif /* GHCI */