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