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