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