Enable stack traces with ghci -fexternal-interpreter -prof
[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', wanted) <- captureConstraints tc_action
532 ; const_binds <- simplifyTop wanted
533
534 -- Zonk it and tie the knot of dictionary bindings
535 ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') }
536
537 {-
538 ************************************************************************
539 * *
540 Annotations
541 * *
542 ************************************************************************
543 -}
544
545 runAnnotation target expr = do
546 -- Find the classes we want instances for in order to call toAnnotationWrapper
547 loc <- getSrcSpanM
548 data_class <- tcLookupClass dataClassName
549 to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
550
551 -- Check the instances we require live in another module (we want to execute it..)
552 -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
553 -- also resolves the LIE constraints to detect e.g. instance ambiguity
554 zonked_wrapped_expr' <- tcTopSpliceExpr Untyped $
555 do { (expr', expr_ty) <- tcInferRhoNC expr
556 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
557 -- By instantiating the call >here< it gets registered in the
558 -- LIE consulted by tcTopSpliceExpr
559 -- and hence ensures the appropriate dictionary is bound by const_binds
560 ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
561 ; let specialised_to_annotation_wrapper_expr
562 = L loc (HsWrap wrapper
563 (HsVar (L loc to_annotation_wrapper_id)))
564 ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
565
566 -- Run the appropriately wrapped expression to get the value of
567 -- the annotation and its dictionaries. The return value is of
568 -- type AnnotationWrapper by construction, so this conversion is
569 -- safe
570 serialized <- runMetaAW zonked_wrapped_expr'
571 return Annotation {
572 ann_target = target,
573 ann_value = serialized
574 }
575
576 convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)
577 convertAnnotationWrapper fhv = do
578 dflags <- getDynFlags
579 if gopt Opt_ExternalInterpreter dflags
580 then do
581 Right <$> runTH THAnnWrapper fhv
582 else do
583 annotation_wrapper <- liftIO $ wormhole dflags fhv
584 return $ Right $
585 case unsafeCoerce# annotation_wrapper of
586 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
587 -- Got the value and dictionaries: build the serialized value and
588 -- call it a day. We ensure that we seq the entire serialized value
589 -- in order that any errors in the user-written code for the
590 -- annotation are exposed at this point. This is also why we are
591 -- doing all this stuff inside the context of runMeta: it has the
592 -- facilities to deal with user error in a meta-level expression
593 seqSerialized serialized `seq` serialized
594
595 -- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
596 seqSerialized :: Serialized -> ()
597 seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
598
599
600 {-
601 ************************************************************************
602 * *
603 \subsection{Running an expression}
604 * *
605 ************************************************************************
606 -}
607
608 runQuasi :: TH.Q a -> TcM a
609 runQuasi act = TH.runQ act
610
611 runQResult
612 :: (a -> String)
613 -> (SrcSpan -> a -> b)
614 -> (ForeignHValue -> TcM a)
615 -> SrcSpan
616 -> ForeignHValue {- TH.Q a -}
617 -> TcM b
618 runQResult show_th f runQ expr_span hval
619 = do { th_result <- runQ hval
620 ; traceTc "Got TH result:" (text (show_th th_result))
621 ; return (f expr_span th_result) }
622
623
624 -----------------
625 runMeta :: (MetaHook TcM -> LHsExpr Id -> TcM hs_syn)
626 -> LHsExpr Id
627 -> TcM hs_syn
628 runMeta unwrap e
629 = do { h <- getHooked runMetaHook defaultRunMeta
630 ; unwrap h e }
631
632 defaultRunMeta :: MetaHook TcM
633 defaultRunMeta (MetaE r)
634 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)
635 defaultRunMeta (MetaP r)
636 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)
637 defaultRunMeta (MetaT r)
638 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)
639 defaultRunMeta (MetaD r)
640 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)
641 defaultRunMeta (MetaAW r)
642 = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)
643 -- We turn off showing the code in meta-level exceptions because doing so exposes
644 -- the toAnnotationWrapper function that we slap around the users code
645
646 ----------------
647 runMetaAW :: LHsExpr Id -- Of type AnnotationWrapper
648 -> TcM Serialized
649 runMetaAW = runMeta metaRequestAW
650
651 runMetaE :: LHsExpr Id -- Of type (Q Exp)
652 -> TcM (LHsExpr RdrName)
653 runMetaE = runMeta metaRequestE
654
655 runMetaP :: LHsExpr Id -- Of type (Q Pat)
656 -> TcM (LPat RdrName)
657 runMetaP = runMeta metaRequestP
658
659 runMetaT :: LHsExpr Id -- Of type (Q Type)
660 -> TcM (LHsType RdrName)
661 runMetaT = runMeta metaRequestT
662
663 runMetaD :: LHsExpr Id -- Of type Q [Dec]
664 -> TcM [LHsDecl RdrName]
665 runMetaD = runMeta metaRequestD
666
667 ---------------
668 runMeta' :: Bool -- Whether code should be printed in the exception message
669 -> (hs_syn -> SDoc) -- how to print the code
670 -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x
671 -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that
672 -> TcM hs_syn -- Of type t
673 runMeta' show_code ppr_hs run_and_convert expr
674 = do { traceTc "About to run" (ppr expr)
675 ; recordThSpliceUse -- seems to be the best place to do this,
676 -- we catch all kinds of splices and annotations.
677
678 -- Check that we've had no errors of any sort so far.
679 -- For example, if we found an error in an earlier defn f, but
680 -- recovered giving it type f :: forall a.a, it'd be very dodgy
681 -- to carry ont. Mind you, the staging restrictions mean we won't
682 -- actually run f, but it still seems wrong. And, more concretely,
683 -- see Trac #5358 for an example that fell over when trying to
684 -- reify a function with a "?" kind in it. (These don't occur
685 -- in type-correct programs.
686 ; failIfErrsM
687
688 -- Desugar
689 ; ds_expr <- initDsTc (dsLExpr expr)
690 -- Compile and link it; might fail if linking fails
691 ; hsc_env <- getTopEnv
692 ; src_span <- getSrcSpanM
693 ; traceTc "About to run (desugared)" (ppr ds_expr)
694 ; either_hval <- tryM $ liftIO $
695 HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
696 ; case either_hval of {
697 Left exn -> fail_with_exn "compile and link" exn ;
698 Right hval -> do
699
700 { -- Coerce it to Q t, and run it
701
702 -- Running might fail if it throws an exception of any kind (hence tryAllM)
703 -- including, say, a pattern-match exception in the code we are running
704 --
705 -- We also do the TH -> HS syntax conversion inside the same
706 -- exception-cacthing thing so that if there are any lurking
707 -- exceptions in the data structure returned by hval, we'll
708 -- encounter them inside the try
709 --
710 -- See Note [Exceptions in TH]
711 let expr_span = getLoc expr
712 ; either_tval <- tryAllM $
713 setSrcSpan expr_span $ -- Set the span so that qLocation can
714 -- see where this splice is
715 do { mb_result <- run_and_convert expr_span hval
716 ; case mb_result of
717 Left err -> failWithTc err
718 Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
719 ; return $! result } }
720
721 ; case either_tval of
722 Right v -> return v
723 Left se -> case fromException se of
724 Just IOEnvFailure -> failM -- Error already in Tc monad
725 _ -> fail_with_exn "run" se -- Exception
726 }}}
727 where
728 -- see Note [Concealed TH exceptions]
729 fail_with_exn :: Exception e => String -> e -> TcM a
730 fail_with_exn phase exn = do
731 exn_msg <- liftIO $ Panic.safeShowException exn
732 let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
733 nest 2 (text exn_msg),
734 if show_code then text "Code:" <+> ppr expr else empty]
735 failWithTc msg
736
737 {-
738 Note [Exceptions in TH]
739 ~~~~~~~~~~~~~~~~~~~~~~~
740 Suppose we have something like this
741 $( f 4 )
742 where
743 f :: Int -> Q [Dec]
744 f n | n>3 = fail "Too many declarations"
745 | otherwise = ...
746
747 The 'fail' is a user-generated failure, and should be displayed as a
748 perfectly ordinary compiler error message, not a panic or anything
749 like that. Here's how it's processed:
750
751 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
752 effectively transforms (fail s) to
753 qReport True s >> fail
754 where 'qReport' comes from the Quasi class and fail from its monad
755 superclass.
756
757 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
758 (qReport True s) by using addErr to add an error message to the bag of errors.
759 The 'fail' in TcM raises an IOEnvFailure exception
760
761 * 'qReport' forces the message to ensure any exception hidden in unevaluated
762 thunk doesn't get into the bag of errors. Otherwise the following splice
763 will triger panic (Trac #8987):
764 $(fail undefined)
765 See also Note [Concealed TH exceptions]
766
767 * So, when running a splice, we catch all exceptions; then for
768 - an IOEnvFailure exception, we assume the error is already
769 in the error-bag (above)
770 - other errors, we add an error to the bag
771 and then fail
772
773 Note [Concealed TH exceptions]
774 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
775 When displaying the error message contained in an exception originated from TH
776 code, we need to make sure that the error message itself does not contain an
777 exception. For example, when executing the following splice:
778
779 $( error ("foo " ++ error "bar") )
780
781 the message for the outer exception is a thunk which will throw the inner
782 exception when evaluated.
783
784 For this reason, we display the message of a TH exception using the
785 'safeShowException' function, which recursively catches any exception thrown
786 when showing an error message.
787
788
789 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
790 -}
791
792 instance TH.Quasi TcM where
793 qNewName s = do { u <- newUnique
794 ; let i = getKey u
795 ; return (TH.mkNameU s i) }
796
797 -- 'msg' is forced to ensure exceptions don't escape,
798 -- see Note [Exceptions in TH]
799 qReport True msg = seqList msg $ addErr (text msg)
800 qReport False msg = seqList msg $ addWarn (text msg)
801
802 qLocation = do { m <- getModule
803 ; l <- getSrcSpanM
804 ; r <- case l of
805 UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
806 (ppr l)
807 RealSrcSpan s -> return s
808 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
809 , TH.loc_module = moduleNameString (moduleName m)
810 , TH.loc_package = unitIdString (moduleUnitId m)
811 , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
812 , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
813
814 qLookupName = lookupName
815 qReify = reify
816 qReifyFixity nm = lookupThName nm >>= reifyFixity
817 qReifyInstances = reifyInstances
818 qReifyRoles = reifyRoles
819 qReifyAnnotations = reifyAnnotations
820 qReifyModule = reifyModule
821 qReifyConStrictness nm = do { nm' <- lookupThName nm
822 ; dc <- tcLookupDataCon nm'
823 ; let bangs = dataConImplBangs dc
824 ; return (map reifyDecidedStrictness bangs) }
825
826 -- For qRecover, discard error messages if
827 -- the recovery action is chosen. Otherwise
828 -- we'll only fail higher up. c.f. tryTcLIE_
829 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
830 ; case mb_res of
831 Just val -> do { addMessages msgs -- There might be warnings
832 ; return val }
833 Nothing -> recover -- Discard all msgs
834 }
835
836 qRunIO io = liftIO io
837
838 qAddDependentFile fp = do
839 ref <- fmap tcg_dependent_files getGblEnv
840 dep_files <- readTcRef ref
841 writeTcRef ref (fp:dep_files)
842
843 qAddTopDecls thds = do
844 l <- getSrcSpanM
845 let either_hval = convertToHsDecls l thds
846 ds <- case either_hval of
847 Left exn -> pprPanic "qAddTopDecls: can't convert top-level declarations" exn
848 Right ds -> return ds
849 mapM_ (checkTopDecl . unLoc) ds
850 th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
851 updTcRef th_topdecls_var (\topds -> ds ++ topds)
852 where
853 checkTopDecl :: HsDecl RdrName -> TcM ()
854 checkTopDecl (ValD binds)
855 = mapM_ bindName (collectHsBindBinders binds)
856 checkTopDecl (SigD _)
857 = return ()
858 checkTopDecl (AnnD _)
859 = return ()
860 checkTopDecl (ForD (ForeignImport { fd_name = L _ name }))
861 = bindName name
862 checkTopDecl _
863 = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"
864
865 bindName :: RdrName -> TcM ()
866 bindName (Exact n)
867 = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
868 ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
869 }
870
871 bindName name =
872 addErr $
873 hang (ptext (sLit "The binder") <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))
874 2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
875
876 qAddModFinalizer fin = do
877 th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
878 updTcRef th_modfinalizers_var (\fins -> fin:fins)
879
880 qGetQ :: forall a. Typeable a => TcM (Maybe a)
881 qGetQ = do
882 th_state_var <- fmap tcg_th_state getGblEnv
883 th_state <- readTcRef th_state_var
884 -- See #10596 for why we use a scoped type variable here.
885 return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
886
887 qPutQ x = do
888 th_state_var <- fmap tcg_th_state getGblEnv
889 updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
890
891 qIsExtEnabled = xoptM
892
893 qExtsEnabled = do
894 dflags <- hsc_dflags <$> getTopEnv
895 return $ map toEnum $ IntSet.elems $ extensionFlags dflags
896
897
898 -- | Run all module finalizers
899 finishTH :: TcM ()
900 finishTH = do
901 hsc_env <- env_top <$> getEnv
902 dflags <- getDynFlags
903 if not (gopt Opt_ExternalInterpreter dflags)
904 then do
905 tcg <- getGblEnv
906 let th_modfinalizers_var = tcg_th_modfinalizers tcg
907 modfinalizers <- readTcRef th_modfinalizers_var
908 writeTcRef th_modfinalizers_var []
909 mapM_ runQuasi modfinalizers
910 else withIServ hsc_env $ \i -> do
911 tcg <- getGblEnv
912 th_state <- readTcRef (tcg_th_remote_state tcg)
913 case th_state of
914 Nothing -> return () -- TH was not started, nothing to do
915 Just fhv -> do
916 liftIO $ withForeignRef fhv $ \rhv ->
917 writeIServ i (putMessage (FinishTH rhv))
918 () <- runRemoteTH i
919 writeTcRef (tcg_th_remote_state tcg) Nothing
920
921 runTHExp :: ForeignHValue -> TcM TH.Exp
922 runTHExp = runTH THExp
923
924 runTHPat :: ForeignHValue -> TcM TH.Pat
925 runTHPat = runTH THPat
926
927 runTHType :: ForeignHValue -> TcM TH.Type
928 runTHType = runTH THType
929
930 runTHDec :: ForeignHValue -> TcM [TH.Dec]
931 runTHDec = runTH THDec
932
933 runTH :: Binary a => THResultType -> ForeignHValue -> TcM a
934 runTH ty fhv = do
935 hsc_env <- env_top <$> getEnv
936 dflags <- getDynFlags
937 if not (gopt Opt_ExternalInterpreter dflags)
938 then do
939 -- just run it in the local TcM
940 hv <- liftIO $ wormhole dflags fhv
941 r <- runQuasi (unsafeCoerce# hv :: TH.Q a)
942 return r
943 else
944 -- run it on the server
945 withIServ hsc_env $ \i -> do
946 rstate <- getTHState i
947 loc <- TH.qLocation
948 liftIO $
949 withForeignRef rstate $ \state_hv ->
950 withForeignRef fhv $ \q_hv ->
951 writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))
952 bs <- runRemoteTH i
953 return $! runGet get (LB.fromStrict bs)
954
955 -- | communicate with a remotely-running TH computation until it
956 -- finishes and returns a result.
957 runRemoteTH :: Binary a => IServ -> TcM a
958 runRemoteTH iserv = do
959 Msg msg <- liftIO $ readIServ iserv getMessage
960 case msg of
961 QDone -> liftIO $ readIServ iserv get
962 QException str -> liftIO $ throwIO (ErrorCall str)
963 QFail str -> fail str
964 _other -> do
965 r <- handleTHMessage msg
966 liftIO $ writeIServ iserv (put r)
967 runRemoteTH iserv
968
969 getTHState :: IServ -> TcM (ForeignRef (IORef QState))
970 getTHState i = do
971 tcg <- getGblEnv
972 th_state <- readTcRef (tcg_th_remote_state tcg)
973 case th_state of
974 Just rhv -> return rhv
975 Nothing -> do
976 hsc_env <- env_top <$> getEnv
977 fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH
978 writeTcRef (tcg_th_remote_state tcg) (Just fhv)
979 return fhv
980
981 wrapTHResult :: TcM a -> TcM (THResult a)
982 wrapTHResult tcm = do
983 e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic
984 case e of
985 Left e -> return (THException (show e))
986 Right a -> return (THComplete a)
987
988 handleTHMessage :: Message a -> TcM a
989 handleTHMessage msg = case msg of
990 NewName a -> wrapTHResult $ TH.qNewName a
991 Report b str -> wrapTHResult $ TH.qReport b str
992 LookupName b str -> wrapTHResult $ TH.qLookupName b str
993 Reify n -> wrapTHResult $ TH.qReify n
994 ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
995 ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
996 ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
997 ReifyAnnotations lookup tyrep ->
998 wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
999 ReifyModule m -> wrapTHResult $ TH.qReifyModule m
1000 AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
1001 AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
1002 IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
1003 ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
1004 _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
1005
1006 getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
1007 getAnnotationsByTypeRep th_name tyrep
1008 = do { name <- lookupThAnnLookup th_name
1009 ; topEnv <- getTopEnv
1010 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1011 ; tcg <- getGblEnv
1012 ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep
1013 ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep
1014 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1015
1016 {-
1017 ************************************************************************
1018 * *
1019 Instance Testing
1020 * *
1021 ************************************************************************
1022 -}
1023
1024 reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
1025 reifyInstances th_nm th_tys
1026 = addErrCtxt (ptext (sLit "In the argument of reifyInstances:")
1027 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
1028 do { loc <- getSrcSpanM
1029 ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)
1030 -- #9262 says to bring vars into scope, like in HsForAllTy case
1031 -- of rnHsTyKi
1032 ; free_vars <- extractHsTyRdrTyVars rdr_ty
1033 ; let tv_rdrs = freeKiTyVarsAllVars free_vars
1034 -- Rename to HsType Name
1035 ; ((tv_names, rn_ty), _fvs)
1036 <- bindLRdrNames tv_rdrs $ \ tv_names ->
1037 do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
1038 ; return ((tv_names, rn_ty), fvs) }
1039 ; (_tvs, ty)
1040 <- solveEqualities $
1041 tcImplicitTKBndrsType tv_names $
1042 fst <$> tcLHsType rn_ty
1043 ; ty <- zonkTcTypeToType emptyZonkEnv ty
1044 -- Substitute out the meta type variables
1045 -- In particular, the type might have kind
1046 -- variables inside it (Trac #7477)
1047
1048 ; traceTc "reifyInstances" (ppr ty $$ ppr (typeKind ty))
1049 ; case splitTyConApp_maybe ty of -- This expands any type synonyms
1050 Just (tc, tys) -- See Trac #7910
1051 | Just cls <- tyConClass_maybe tc
1052 -> do { inst_envs <- tcGetInstEnvs
1053 ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys
1054 ; traceTc "reifyInstances1" (ppr matches)
1055 ; reifyClassInstances cls (map fst matches ++ unifies) }
1056 | isOpenFamilyTyCon tc
1057 -> do { inst_envs <- tcGetFamInstEnvs
1058 ; let matches = lookupFamInstEnv inst_envs tc tys
1059 ; traceTc "reifyInstances2" (ppr matches)
1060 ; reifyFamilyInstances tc (map fim_instance matches) }
1061 _ -> bale_out (hang (ptext (sLit "reifyInstances:") <+> quotes (ppr ty))
1062 2 (ptext (sLit "is not a class constraint or type family application"))) }
1063 where
1064 doc = ClassInstanceCtx
1065 bale_out msg = failWithTc msg
1066
1067 cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName)
1068 cvt loc th_ty = case convertToHsType loc th_ty of
1069 Left msg -> failWithTc msg
1070 Right ty -> return ty
1071
1072 {-
1073 ************************************************************************
1074 * *
1075 Reification
1076 * *
1077 ************************************************************************
1078 -}
1079
1080 lookupName :: Bool -- True <=> type namespace
1081 -- False <=> value namespace
1082 -> String -> TcM (Maybe TH.Name)
1083 lookupName is_type_name s
1084 = do { lcl_env <- getLocalRdrEnv
1085 ; case lookupLocalRdrEnv lcl_env rdr_name of
1086 Just n -> return (Just (reifyName n))
1087 Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name
1088 ; return (fmap reifyName mb_nm) } }
1089 where
1090 th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M'
1091
1092 occ_fs :: FastString
1093 occ_fs = mkFastString (TH.nameBase th_name)
1094
1095 occ :: OccName
1096 occ | is_type_name
1097 = if isLexCon occ_fs then mkTcOccFS occ_fs
1098 else mkTyVarOccFS occ_fs
1099 | otherwise
1100 = if isLexCon occ_fs then mkDataOccFS occ_fs
1101 else mkVarOccFS occ_fs
1102
1103 rdr_name = case TH.nameModule th_name of
1104 Nothing -> mkRdrUnqual occ
1105 Just mod -> mkRdrQual (mkModuleName mod) occ
1106
1107 getThing :: TH.Name -> TcM TcTyThing
1108 getThing th_name
1109 = do { name <- lookupThName th_name
1110 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
1111 ; tcLookupTh name }
1112 -- ToDo: this tcLookup could fail, which would give a
1113 -- rather unhelpful error message
1114 where
1115 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
1116 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
1117 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
1118 ppr_ns _ = panic "reify/ppr_ns"
1119
1120 reify :: TH.Name -> TcM TH.Info
1121 reify th_name
1122 = do { traceTc "reify 1" (text (TH.showName th_name))
1123 ; thing <- getThing th_name
1124 ; traceTc "reify 2" (ppr thing)
1125 ; reifyThing thing }
1126
1127 lookupThName :: TH.Name -> TcM Name
1128 lookupThName th_name = do
1129 mb_name <- lookupThName_maybe th_name
1130 case mb_name of
1131 Nothing -> failWithTc (notInScope th_name)
1132 Just name -> return name
1133
1134 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
1135 lookupThName_maybe th_name
1136 = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
1137 -- Pick the first that works
1138 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
1139 ; return (listToMaybe names) }
1140 where
1141 lookup rdr_name
1142 = do { -- Repeat much of lookupOccRn, becase we want
1143 -- to report errors in a TH-relevant way
1144 ; rdr_env <- getLocalRdrEnv
1145 ; case lookupLocalRdrEnv rdr_env rdr_name of
1146 Just name -> return (Just name)
1147 Nothing -> lookupGlobalOccRn_maybe rdr_name }
1148
1149 tcLookupTh :: Name -> TcM TcTyThing
1150 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
1151 -- it gives a reify-related error message on failure, whereas in the normal
1152 -- tcLookup, failure is a bug.
1153 tcLookupTh name
1154 = do { (gbl_env, lcl_env) <- getEnvs
1155 ; case lookupNameEnv (tcl_env lcl_env) name of {
1156 Just thing -> return thing;
1157 Nothing ->
1158
1159 case lookupNameEnv (tcg_type_env gbl_env) name of {
1160 Just thing -> return (AGlobal thing);
1161 Nothing ->
1162
1163 if nameIsLocalOrFrom (tcg_mod gbl_env) name
1164 then -- It's defined in this module
1165 failWithTc (notInEnv name)
1166
1167 else
1168 do { mb_thing <- tcLookupImported_maybe name
1169 ; case mb_thing of
1170 Succeeded thing -> return (AGlobal thing)
1171 Failed msg -> failWithTc msg
1172 }}}}
1173
1174 notInScope :: TH.Name -> SDoc
1175 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
1176 ptext (sLit "is not in scope at a reify")
1177 -- Ugh! Rather an indirect way to display the name
1178
1179 notInEnv :: Name -> SDoc
1180 notInEnv name = quotes (ppr name) <+>
1181 ptext (sLit "is not in the type environment at a reify")
1182
1183 ------------------------------
1184 reifyRoles :: TH.Name -> TcM [TH.Role]
1185 reifyRoles th_name
1186 = do { thing <- getThing th_name
1187 ; case thing of
1188 AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
1189 _ -> failWithTc (ptext (sLit "No roles associated with") <+> (ppr thing))
1190 }
1191 where
1192 reify_role Nominal = TH.NominalR
1193 reify_role Representational = TH.RepresentationalR
1194 reify_role Phantom = TH.PhantomR
1195
1196 ------------------------------
1197 reifyThing :: TcTyThing -> TcM TH.Info
1198 -- The only reason this is monadic is for error reporting,
1199 -- which in turn is mainly for the case when TH can't express
1200 -- some random GHC extension
1201
1202 reifyThing (AGlobal (AnId id))
1203 = do { ty <- reifyType (idType id)
1204 ; let v = reifyName id
1205 ; case idDetails id of
1206 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))
1207 RecSelId{sel_tycon=RecSelData tc}
1208 -> return (TH.VarI (reifySelector id tc) ty Nothing)
1209 _ -> return (TH.VarI v ty Nothing)
1210 }
1211
1212 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
1213 reifyThing (AGlobal (AConLike (RealDataCon dc)))
1214 = do { let name = dataConName dc
1215 ; ty <- reifyType (idType (dataConWrapId dc))
1216 ; return (TH.DataConI (reifyName name) ty
1217 (reifyName (dataConOrigTyCon dc)))
1218 }
1219 reifyThing (AGlobal (AConLike (PatSynCon ps)))
1220 = noTH (sLit "pattern synonyms") (ppr $ patSynName ps)
1221
1222 reifyThing (ATcId {tct_id = id})
1223 = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
1224 -- though it may be incomplete
1225 ; ty2 <- reifyType ty1
1226 ; return (TH.VarI (reifyName id) ty2 Nothing) }
1227
1228 reifyThing (ATyVar tv tv1)
1229 = do { ty1 <- zonkTcTyVar tv1
1230 ; ty2 <- reifyType ty1
1231 ; return (TH.TyVarI (reifyName tv) ty2) }
1232
1233 reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
1234
1235 -------------------------------------------
1236 reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
1237 reifyAxBranch fam_tc (CoAxBranch { cab_lhs = args, cab_rhs = rhs })
1238 -- remove kind patterns (#8884)
1239 = do { args' <- mapM reifyType (filterOutInvisibleTypes fam_tc args)
1240 ; rhs' <- reifyType rhs
1241 ; return (TH.TySynEqn args' rhs') }
1242
1243 reifyTyCon :: TyCon -> TcM TH.Info
1244 reifyTyCon tc
1245 | Just cls <- tyConClass_maybe tc
1246 = reifyClass cls
1247
1248 | isFunTyCon tc
1249 = return (TH.PrimTyConI (reifyName tc) 2 False)
1250
1251 | isPrimTyCon tc
1252 = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
1253
1254 | isTypeFamilyTyCon tc
1255 = do { let tvs = tyConTyVars tc
1256 kind = tyConKind tc
1257 resVar = famTcResVar tc
1258
1259 -- we need the *result kind* (see #8884)
1260 (kvs, mono_kind) = splitForAllTys kind
1261 -- tyConArity includes *kind* params
1262 (_, res_kind) = splitFunTysN (tyConArity tc - length kvs)
1263 mono_kind
1264 ; kind' <- reifyKind res_kind
1265 ; let (resultSig, injectivity) =
1266 case resVar of
1267 Nothing -> (TH.KindSig kind', Nothing)
1268 Just name ->
1269 let thName = reifyName name
1270 injAnnot = familyTyConInjectivityInfo tc
1271 sig = TH.TyVarSig (TH.KindedTV thName kind')
1272 inj = case injAnnot of
1273 NotInjective -> Nothing
1274 Injective ms ->
1275 Just (TH.InjectivityAnn thName injRHS)
1276 where
1277 injRHS = map (reifyName . tyVarName)
1278 (filterByList ms tvs)
1279 in (sig, inj)
1280 ; tvs' <- reifyTyVars tvs (Just tc)
1281 ; let tfHead =
1282 TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity
1283 ; if isOpenTypeFamilyTyCon tc
1284 then do { fam_envs <- tcGetFamInstEnvs
1285 ; instances <- reifyFamilyInstances tc
1286 (familyInstances fam_envs tc)
1287 ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) }
1288 else do { eqns <-
1289 case isClosedSynFamilyTyConWithAxiom_maybe tc of
1290 Just ax -> mapM (reifyAxBranch tc) $
1291 fromBranches $ coAxiomBranches ax
1292 Nothing -> return []
1293 ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns)
1294 []) } }
1295
1296 | isDataFamilyTyCon tc
1297 = do { let tvs = tyConTyVars tc
1298 kind = tyConKind tc
1299
1300 -- we need the *result kind* (see #8884)
1301 (kvs, mono_kind) = splitForAllTys kind
1302 -- tyConArity includes *kind* params
1303 (_, res_kind) = splitFunTysN (tyConArity tc - length kvs)
1304 mono_kind
1305 ; kind' <- fmap Just (reifyKind res_kind)
1306
1307 ; tvs' <- reifyTyVars tvs (Just tc)
1308 ; fam_envs <- tcGetFamInstEnvs
1309 ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)
1310 ; return (TH.FamilyI
1311 (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }
1312
1313 | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym
1314 = do { rhs' <- reifyType rhs
1315 ; tvs' <- reifyTyVars tvs (Just tc)
1316 ; return (TH.TyConI
1317 (TH.TySynD (reifyName tc) tvs' rhs'))
1318 }
1319
1320 | otherwise
1321 = do { cxt <- reifyCxt (tyConStupidTheta tc)
1322 ; let tvs = tyConTyVars tc
1323 dataCons = tyConDataCons tc
1324 -- see Note [Reifying GADT data constructors]
1325 isGadt = any (not . null . dataConEqSpec) dataCons
1326 ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
1327 ; r_tvs <- reifyTyVars tvs (Just tc)
1328 ; let name = reifyName tc
1329 deriv = [] -- Don't know about deriving
1330 decl | isNewTyCon tc =
1331 TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv
1332 | otherwise =
1333 TH.DataD cxt name r_tvs Nothing cons deriv
1334 ; return (TH.TyConI decl) }
1335
1336 reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con
1337 -- For GADTs etc, see Note [Reifying GADT data constructors]
1338 reifyDataCon isGadtDataCon tys dc
1339 = do { let -- used for H98 data constructors
1340 (ex_tvs, theta, arg_tys)
1341 = dataConInstSig dc tys
1342 -- used for GADTs data constructors
1343 (g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, g_res_ty)
1344 = dataConFullSig dc
1345 (srcUnpks, srcStricts)
1346 = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
1347 dcdBangs = zipWith TH.Bang srcUnpks srcStricts
1348 fields = dataConFieldLabels dc
1349 name = reifyName dc
1350 -- Universal tvs present in eq_spec need to be filtered out, as
1351 -- they will not appear anywhere in the type.
1352 subst = mkTopTCvSubst (map eqSpecPair g_eq_spec)
1353 g_unsbst_univ_tvs = filter (`notElemTCvSubst` subst) g_univ_tvs
1354
1355 ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
1356
1357 ; let [r_a1, r_a2] = r_arg_tys
1358 [s1, s2] = dcdBangs
1359
1360 ; main_con <-
1361 if | not (null fields) && not isGadtDataCon ->
1362 return $ TH.RecC name (zip3 (map reifyFieldLabel fields)
1363 dcdBangs r_arg_tys)
1364 | not (null fields) -> do
1365 { res_ty <- reifyType g_res_ty
1366 ; return $ TH.RecGadtC [name]
1367 (zip3 (map (reifyName . flSelector) fields)
1368 dcdBangs r_arg_tys) res_ty }
1369 | dataConIsInfix dc ->
1370 ASSERT( length arg_tys == 2 )
1371 return $ TH.InfixC (s1,r_a1) name (s2,r_a2)
1372 | isGadtDataCon -> do
1373 { res_ty <- reifyType g_res_ty
1374 ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }
1375 | otherwise ->
1376 return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
1377
1378 ; let (ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs
1379 , g_theta )
1380 | otherwise = ( ex_tvs, theta )
1381 ret_con | null ex_tvs' && null theta' = return main_con
1382 | otherwise = do
1383 { cxt <- reifyCxt theta'
1384 ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing
1385 ; return (TH.ForallC ex_tvs'' cxt main_con) }
1386 ; ASSERT( length arg_tys == length dcdBangs )
1387 ret_con }
1388
1389 -- Note [Reifying GADT data constructors]
1390 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1391 -- At this point in the compilation pipeline we have no way of telling whether a
1392 -- data type was declared as a H98 data type or as a GADT. We have to rely on
1393 -- heuristics here. We look at dcEqSpec field of all data constructors in a
1394 -- data type declaration. If at least one data constructor has non-empty
1395 -- dcEqSpec this means that the data type must have been declared as a GADT.
1396 -- Consider these declarations:
1397 --
1398 -- data T a where
1399 -- MkT :: forall a. (a ~ Int) => T a
1400 --
1401 -- data T a where
1402 -- MkT :: T Int
1403 --
1404 -- First declaration will be reified as a GADT. Second declaration will be
1405 -- reified as a normal H98 data type declaration.
1406
1407 ------------------------------
1408 reifyClass :: Class -> TcM TH.Info
1409 reifyClass cls
1410 = do { cxt <- reifyCxt theta
1411 ; inst_envs <- tcGetInstEnvs
1412 ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
1413 ; assocTys <- concatMapM reifyAT ats
1414 ; ops <- concatMapM reify_op op_stuff
1415 ; tvs' <- reifyTyVars tvs (Just $ classTyCon cls)
1416 ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
1417 ; return (TH.ClassI dec insts) }
1418 where
1419 (tvs, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
1420 fds' = map reifyFunDep fds
1421 reify_op (op, def_meth)
1422 = do { ty <- reifyType (idType op)
1423 ; let nm' = reifyName op
1424 ; case def_meth of
1425 Just (_, GenericDM gdm_ty) ->
1426 do { gdm_ty' <- reifyType gdm_ty
1427 ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty'] }
1428 _ -> return [TH.SigD nm' ty] }
1429
1430 reifyAT :: ClassATItem -> TcM [TH.Dec]
1431 reifyAT (ATI tycon def) = do
1432 tycon' <- reifyTyCon tycon
1433 case tycon' of
1434 TH.FamilyI dec _ -> do
1435 let (tyName, tyArgs) = tfNames dec
1436 (dec :) <$> maybe (return [])
1437 (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
1438 def
1439 _ -> pprPanic "reifyAT" (text (show tycon'))
1440
1441 reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
1442 reifyDefImpl n args ty =
1443 TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty
1444
1445 tfNames :: TH.Dec -> (TH.Name, [TH.Name])
1446 tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
1447 = (n, map bndrName args)
1448 tfNames d = pprPanic "tfNames" (text (show d))
1449
1450 bndrName :: TH.TyVarBndr -> TH.Name
1451 bndrName (TH.PlainTV n) = n
1452 bndrName (TH.KindedTV n _) = n
1453
1454 ------------------------------
1455 -- | Annotate (with TH.SigT) a type if the first parameter is True
1456 -- and if the type contains a free variable.
1457 -- This is used to annotate type patterns for poly-kinded tyvars in
1458 -- reifying class and type instances. See #8953 and th/T8953.
1459 annotThType :: Bool -- True <=> annotate
1460 -> TyCoRep.Type -> TH.Type -> TcM TH.Type
1461 -- tiny optimization: if the type is annotated, don't annotate again.
1462 annotThType _ _ th_ty@(TH.SigT {}) = return th_ty
1463 annotThType True ty th_ty
1464 | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
1465 = do { let ki = typeKind ty
1466 ; th_ki <- reifyKind ki
1467 ; return (TH.SigT th_ty th_ki) }
1468 annotThType _ _ th_ty = return th_ty
1469
1470 -- | For every type variable in the input,
1471 -- report whether or not the tv is poly-kinded. This is used to eventually
1472 -- feed into 'annotThType'.
1473 mkIsPolyTvs :: [TyVar] -> [Bool]
1474 mkIsPolyTvs = map is_poly_tv
1475 where
1476 is_poly_tv tv = not $
1477 isEmptyVarSet $
1478 filterVarSet isTyVar $
1479 tyCoVarsOfType $
1480 tyVarKind tv
1481
1482 ------------------------------
1483 reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
1484 reifyClassInstances cls insts
1485 = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
1486 where
1487 tvs = filterOutInvisibleTyVars (classTyCon cls) (classTyVars cls)
1488
1489 reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1490 -- includes only *visible* tvs
1491 -> ClsInst -> TcM TH.Dec
1492 reifyClassInstance is_poly_tvs i
1493 = do { cxt <- reifyCxt theta
1494 ; let vis_types = filterOutInvisibleTypes cls_tc types
1495 ; thtypes <- reifyTypes vis_types
1496 ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
1497 ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
1498 ; return $ (TH.InstanceD cxt head_ty []) }
1499 where
1500 (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
1501 cls_tc = classTyCon cls
1502 dfun = instanceDFunId i
1503
1504 ------------------------------
1505 reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
1506 reifyFamilyInstances fam_tc fam_insts
1507 = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
1508 where
1509 fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
1510
1511 reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1512 -- includes only *visible* tvs
1513 -> FamInst -> TcM TH.Dec
1514 reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
1515 , fi_fam = fam
1516 , fi_tys = lhs
1517 , fi_rhs = rhs })
1518 = case flavor of
1519 SynFamilyInst ->
1520 -- remove kind patterns (#8884)
1521 do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
1522 ; th_lhs <- reifyTypes lhs_types_only
1523 ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
1524 th_lhs
1525 ; th_rhs <- reifyType rhs
1526 ; return (TH.TySynInstD (reifyName fam)
1527 (TH.TySynEqn annot_th_lhs th_rhs)) }
1528
1529 DataFamilyInst rep_tc ->
1530 do { let tvs = tyConTyVars rep_tc
1531 fam' = reifyName fam
1532
1533 -- eta-expand lhs types, because sometimes data/newtype
1534 -- instances are eta-reduced; See Trac #9692
1535 -- See Note [Eta reduction for data family axioms]
1536 -- in TcInstDcls
1537 (_rep_tc, rep_tc_args) = splitTyConApp rhs
1538 etad_tyvars = dropList rep_tc_args tvs
1539 eta_expanded_lhs = lhs `chkAppend` mkTyVarTys etad_tyvars
1540 dataCons = tyConDataCons rep_tc
1541 -- see Note [Reifying GADT data constructors]
1542 isGadt = any (not . null . dataConEqSpec) dataCons
1543 ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
1544 ; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs
1545 ; th_tys <- reifyTypes types_only
1546 ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
1547 ; return $
1548 if isNewTyCon rep_tc
1549 then TH.NewtypeInstD [] fam' annot_th_tys Nothing (head cons) []
1550 else TH.DataInstD [] fam' annot_th_tys Nothing cons []
1551 }
1552 where
1553 fam_tc = famInstTyCon inst
1554
1555 ------------------------------
1556 reifyType :: TyCoRep.Type -> TcM TH.Type
1557 -- Monadic only because of failure
1558 reifyType ty@(ForAllTy (Named _ _) _) = reify_for_all ty
1559 reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) }
1560 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1561 reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
1562 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1563 reifyType ty@(ForAllTy (Anon t1) t2)
1564 | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
1565 | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1566 reifyType ty@(CastTy {}) = noTH (sLit "kind casts") (ppr ty)
1567 reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)
1568
1569 reify_for_all :: TyCoRep.Type -> TcM TH.Type
1570 reify_for_all ty
1571 = do { cxt' <- reifyCxt cxt;
1572 ; tau' <- reifyType tau
1573 ; tvs' <- reifyTyVars tvs Nothing
1574 ; return (TH.ForallT tvs' cxt' tau') }
1575 where
1576 (tvs, cxt, tau) = tcSplitSigmaTy ty
1577
1578 reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
1579 reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
1580 reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
1581
1582 reifyTypes :: [Type] -> TcM [TH.Type]
1583 reifyTypes = mapM reifyType
1584
1585 reifyKind :: Kind -> TcM TH.Kind
1586 reifyKind ki
1587 = do { let (kis, ki') = splitFunTys ki
1588 ; ki'_rep <- reifyNonArrowKind ki'
1589 ; kis_rep <- mapM reifyKind kis
1590 ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) }
1591 where
1592 reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT
1593 | isConstraintKind k = return TH.ConstraintT
1594 reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v))
1595 reifyNonArrowKind (ForAllTy _ k) = reifyKind k
1596 reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis
1597 reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1
1598 ; k2' <- reifyKind k2
1599 ; return (TH.AppT k1' k2')
1600 }
1601 reifyNonArrowKind k = noTH (sLit "this kind") (ppr k)
1602
1603 reify_kc_app :: TyCon -> [TyCoRep.Kind] -> TcM TH.Kind
1604 reify_kc_app kc kis
1605 = fmap (mkThAppTs r_kc) (mapM reifyKind kis)
1606 where
1607 r_kc | isTupleTyCon kc = TH.TupleT (tyConArity kc)
1608 | kc `hasKey` listTyConKey = TH.ListT
1609 | otherwise = TH.ConT (reifyName kc)
1610
1611 reifyCxt :: [PredType] -> TcM [TH.Pred]
1612 reifyCxt = mapM reifyPred
1613
1614 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1615 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1616
1617 reifyTyVars :: [TyVar]
1618 -> Maybe TyCon -- the tycon if the tycovars are from a tycon.
1619 -- Used to detect which tvs are implicit.
1620 -> TcM [TH.TyVarBndr]
1621 reifyTyVars tvs m_tc = mapM reify_tv tvs'
1622 where
1623 tvs' = case m_tc of
1624 Just tc -> filterOutInvisibleTyVars tc tvs
1625 Nothing -> tvs
1626
1627 -- even if the kind is *, we need to include a kind annotation,
1628 -- in case a poly-kind would be inferred without the annotation.
1629 -- See #8953 or test th/T8953
1630 reify_tv tv = TH.KindedTV name <$> reifyKind kind
1631 where
1632 kind = tyVarKind tv
1633 name = reifyName tv
1634
1635 {-
1636 Note [Kind annotations on TyConApps]
1637 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1638 A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.
1639 For example:
1640
1641 type family F a :: k
1642 type instance F Int = (Proxy :: * -> *)
1643 type instance F Bool = (Proxy :: (* -> *) -> *)
1644
1645 It's hard to figure out where these annotations should appear, so we do this:
1646 Suppose the tycon is applied to n arguments. We strip off the first n
1647 arguments of the tycon's kind. If there are any variables left in the result
1648 kind, we put on a kind annotation. But we must be slightly careful: it's
1649 possible that the tycon's kind will have fewer than n arguments, in the case
1650 that the concrete application instantiates a result kind variable with an
1651 arrow kind. So, if we run out of arguments, we conservatively put on a kind
1652 annotation anyway. This should be a rare case, indeed. Here is an example:
1653
1654 data T1 :: k1 -> k2 -> *
1655 data T2 :: k1 -> k2 -> *
1656
1657 type family G (a :: k) :: k
1658 type instance G T1 = T2
1659
1660 type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above
1661
1662 Here G's kind is (forall k. k -> k), and the desugared RHS of that last
1663 instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
1664 the algorithm above, there are 3 arguments to G so we should peel off 3
1665 arguments in G's kind. But G's kind has only two arguments. This is the
1666 rare special case, and we conservatively choose to put the annotation
1667 in.
1668
1669 See #8953 and test th/T8953.
1670 -}
1671
1672 reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
1673 reify_tc_app tc tys
1674 = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
1675 ; maybe_sig_t (mkThAppTs r_tc tys') }
1676 where
1677 arity = tyConArity tc
1678 tc_kind = tyConKind tc
1679
1680 r_tc | isTupleTyCon tc = if isPromotedDataCon tc
1681 then TH.PromotedTupleT arity
1682 else TH.TupleT arity
1683 | tc `hasKey` listTyConKey = TH.ListT
1684 | tc `hasKey` nilDataConKey = TH.PromotedNilT
1685 | tc `hasKey` consDataConKey = TH.PromotedConsT
1686 | tc `hasKey` heqTyConKey = TH.EqualityT
1687 | tc `hasKey` eqPrimTyConKey = TH.EqualityT
1688 | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
1689 | otherwise = TH.ConT (reifyName tc)
1690
1691 -- See Note [Kind annotations on TyConApps]
1692 maybe_sig_t th_type
1693 | needs_kind_sig
1694 = do { let full_kind = typeKind (mkTyConApp tc tys)
1695 ; th_full_kind <- reifyKind full_kind
1696 ; return (TH.SigT th_type th_full_kind) }
1697 | otherwise
1698 = return th_type
1699
1700 needs_kind_sig
1701 | Just result_ki <- peel_off_n_args tc_kind (length tys)
1702 = not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType result_ki
1703 | otherwise
1704 = True
1705
1706 peel_off_n_args :: Kind -> Arity -> Maybe Kind
1707 peel_off_n_args k 0 = Just k
1708 peel_off_n_args k n
1709 | Just (_, res_k) <- splitPiTy_maybe k
1710 = peel_off_n_args res_k (n-1)
1711 | otherwise
1712 = Nothing
1713
1714 reifyPred :: TyCoRep.PredType -> TcM TH.Pred
1715 reifyPred ty
1716 -- We could reify the invisible paramter as a class but it seems
1717 -- nicer to support them properly...
1718 | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
1719 | otherwise = reifyType ty
1720
1721 ------------------------------
1722 reifyName :: NamedThing n => n -> TH.Name
1723 reifyName thing
1724 | isExternalName name = mk_varg pkg_str mod_str occ_str
1725 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1726 -- Many of the things we reify have local bindings, and
1727 -- NameL's aren't supposed to appear in binding positions, so
1728 -- we use NameU. When/if we start to reify nested things, that
1729 -- have free variables, we may need to generate NameL's for them.
1730 where
1731 name = getName thing
1732 mod = ASSERT( isExternalName name ) nameModule name
1733 pkg_str = unitIdString (moduleUnitId mod)
1734 mod_str = moduleNameString (moduleName mod)
1735 occ_str = occNameString occ
1736 occ = nameOccName name
1737 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1738 | OccName.isVarOcc occ = TH.mkNameG_v
1739 | OccName.isTcOcc occ = TH.mkNameG_tc
1740 | otherwise = pprPanic "reifyName" (ppr name)
1741
1742 -- See Note [Reifying field labels]
1743 reifyFieldLabel :: FieldLabel -> TH.Name
1744 reifyFieldLabel fl
1745 | flIsOverloaded fl
1746 = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))
1747 | otherwise = TH.mkNameG_v pkg_str mod_str occ_str
1748 where
1749 name = flSelector fl
1750 mod = ASSERT( isExternalName name ) nameModule name
1751 pkg_str = unitIdString (moduleUnitId mod)
1752 mod_str = moduleNameString (moduleName mod)
1753 occ_str = unpackFS (flLabel fl)
1754
1755 reifySelector :: Id -> TyCon -> TH.Name
1756 reifySelector id tc
1757 = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of
1758 Just fl -> reifyFieldLabel fl
1759 Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
1760
1761 ------------------------------
1762 reifyFixity :: Name -> TcM TH.Fixity
1763 reifyFixity name
1764 = do { fix <- lookupFixityRn name
1765 ; return (conv_fix fix) }
1766 where
1767 conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
1768 conv_dir BasicTypes.InfixR = TH.InfixR
1769 conv_dir BasicTypes.InfixL = TH.InfixL
1770 conv_dir BasicTypes.InfixN = TH.InfixN
1771
1772 reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness
1773 reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness
1774 reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack
1775 reifyUnpackedness SrcUnpack = TH.SourceUnpack
1776
1777 reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness
1778 reifyStrictness NoSrcStrict = TH.NoSourceStrictness
1779 reifyStrictness SrcStrict = TH.SourceStrict
1780 reifyStrictness SrcLazy = TH.SourceLazy
1781
1782 reifySourceBang :: DataCon.HsSrcBang
1783 -> (TH.SourceUnpackedness, TH.SourceStrictness)
1784 reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)
1785
1786 reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness
1787 reifyDecidedStrictness HsLazy = TH.DecidedLazy
1788 reifyDecidedStrictness HsStrict = TH.DecidedStrict
1789 reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack
1790
1791 ------------------------------
1792 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
1793 lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
1794 lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
1795 = return $ ModuleTarget $
1796 mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
1797
1798 reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
1799 reifyAnnotations th_name
1800 = do { name <- lookupThAnnLookup th_name
1801 ; topEnv <- getTopEnv
1802 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1803 ; tcg <- getGblEnv
1804 ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
1805 ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
1806 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1807
1808 ------------------------------
1809 modToTHMod :: Module -> TH.Module
1810 modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m)
1811 (TH.ModName $ moduleNameString $ moduleName m)
1812
1813 reifyModule :: TH.Module -> TcM TH.ModuleInfo
1814 reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
1815 this_mod <- getModule
1816 let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)
1817 if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
1818 where
1819 reifyThisModule = do
1820 usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
1821 return $ TH.ModuleInfo usages
1822
1823 reifyFromIface reifMod = do
1824 iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod
1825 let usages = [modToTHMod m | usage <- mi_usages iface,
1826 Just m <- [usageToModule (moduleUnitId reifMod) usage] ]
1827 return $ TH.ModuleInfo usages
1828
1829 usageToModule :: UnitId -> Usage -> Maybe Module
1830 usageToModule _ (UsageFile {}) = Nothing
1831 usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
1832 usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
1833
1834 ------------------------------
1835 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
1836 mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys
1837
1838 noTH :: LitString -> SDoc -> TcM a
1839 noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
1840 ptext (sLit "in Template Haskell:"),
1841 nest 2 d])
1842
1843 ppr_th :: TH.Ppr a => a -> SDoc
1844 ppr_th x = text (TH.pprint x)
1845
1846 {-
1847 Note [Reifying field labels]
1848 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1849 When reifying a datatype declared with DuplicateRecordFields enabled, we want
1850 the reified names of the fields to be labels rather than selector functions.
1851 That is, we want (reify ''T) and (reify 'foo) to produce
1852
1853 data T = MkT { foo :: Int }
1854 foo :: T -> Int
1855
1856 rather than
1857
1858 data T = MkT { $sel:foo:MkT :: Int }
1859 $sel:foo:MkT :: T -> Int
1860
1861 because otherwise TH code that uses the field names as strings will silently do
1862 the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather
1863 than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the
1864 environment, NameG can't be used to represent such fields. Instead,
1865 reifyFieldLabel uses NameQ.
1866
1867 However, this means that extracting the field name from the output of reify, and
1868 trying to reify it again, may fail with an ambiguity error if there are multiple
1869 such fields defined in the module (see the test case
1870 overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to
1871 the TH AST to make it able to represent duplicate record fields.
1872 -}
1873
1874 #endif /* GHCI */