never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE FunctionalDependencies #-}
4 {-# LANGUAGE GADTs #-}
5 {-# LANGUAGE InstanceSigs #-}
6 {-# LANGUAGE MultiWayIf #-}
7 {-# LANGUAGE ScopedTypeVariables #-}
8 {-# LANGUAGE TupleSections #-}
9 {-# LANGUAGE TypeFamilies #-}
10
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
13
14 {-
15 (c) The University of Glasgow 2006
16 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
17
18 -}
19
20 -- | Template Haskell splices
21 module GHC.Tc.Gen.Splice(
22 tcSpliceExpr, tcTypedBracket, tcUntypedBracket,
23 -- runQuasiQuoteExpr, runQuasiQuotePat,
24 -- runQuasiQuoteDecl, runQuasiQuoteType,
25 runAnnotation,
26
27 runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
28 tcTopSpliceExpr, lookupThName_maybe,
29 defaultRunMeta, runMeta', runRemoteModFinalizers,
30 finishTH, runTopSplice
31 ) where
32
33 import GHC.Prelude
34
35 import GHC.Driver.Errors
36 import GHC.Driver.Plugins
37 import GHC.Driver.Main
38 import GHC.Driver.Session
39 import GHC.Driver.Env
40 import GHC.Driver.Hooks
41 import GHC.Driver.Config.Diagnostic
42 import GHC.Driver.Config.Finder
43
44 import GHC.Hs
45
46 import GHC.Tc.Errors.Types
47 import GHC.Tc.Utils.Monad
48 import GHC.Tc.Utils.TcType
49 import GHC.Tc.Gen.Expr
50 import GHC.Tc.Utils.Unify
51 import GHC.Tc.Utils.Env
52 import GHC.Tc.Types.Origin
53 import GHC.Tc.Types.Evidence
54 import GHC.Tc.Utils.Zonk
55 import GHC.Tc.Solver
56 import GHC.Tc.Utils.TcMType
57 import GHC.Tc.Gen.HsType
58 import GHC.Tc.Instance.Family
59 import GHC.Tc.Utils.Instantiate
60
61 import GHC.Core.Multiplicity
62 import GHC.Core.Coercion( etaExpandCoAxBranch )
63 import GHC.Core.Type as Type
64 import GHC.Core.TyCo.Rep as TyCoRep
65 import GHC.Core.FamInstEnv
66 import GHC.Core.InstEnv as InstEnv
67
68 import GHC.Builtin.Names.TH
69 import GHC.Builtin.Names
70 import GHC.Builtin.Types
71
72 import GHC.ThToHs
73 import GHC.HsToCore.Docs
74 import GHC.HsToCore.Expr
75 import GHC.HsToCore.Monad
76 import GHC.IfaceToCore
77 import GHC.Iface.Load
78
79 import GHCi.Message
80 import GHCi.RemoteTypes
81 import GHC.Runtime.Interpreter
82
83 import GHC.Rename.Splice( traceSplice, SpliceInfo(..))
84 import GHC.Rename.Expr
85 import GHC.Rename.Env
86 import GHC.Rename.Utils ( HsDocContext(..) )
87 import GHC.Rename.Fixity ( lookupFixityRn_help )
88 import GHC.Rename.HsType
89
90 import GHC.Core.Class
91 import GHC.Core.TyCon
92 import GHC.Core.Coercion.Axiom
93 import GHC.Core.PatSyn
94 import GHC.Core.ConLike
95 import GHC.Core.DataCon as DataCon
96
97 import GHC.Types.FieldLabel
98 import GHC.Types.SrcLoc
99 import GHC.Types.Name.Env
100 import GHC.Types.Name.Set
101 import GHC.Types.Name.Reader
102 import GHC.Types.Name.Occurrence as OccName
103 import GHC.Types.Var
104 import GHC.Types.Id
105 import GHC.Types.Id.Info
106 import GHC.Types.Unique
107 import GHC.Types.Var.Set
108 import GHC.Types.Meta
109 import GHC.Types.Basic hiding( SuccessFlag(..) )
110 import GHC.Types.Error
111 import GHC.Types.Fixity as Hs
112 import GHC.Types.Annotations
113 import GHC.Types.Name
114 import GHC.Serialized
115
116 import GHC.Unit.Finder
117 import GHC.Unit.Module
118 import GHC.Unit.Module.ModIface
119 import GHC.Unit.Module.Deps
120
121 import GHC.Utils.Misc
122 import GHC.Utils.Panic as Panic
123 import GHC.Utils.Panic.Plain
124 import GHC.Utils.Lexeme
125 import GHC.Utils.Outputable
126 import GHC.Utils.Logger
127 import GHC.Utils.Exception (throwIO, ErrorCall(..))
128
129 import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) )
130
131 import GHC.Data.FastString
132 import GHC.Data.Maybe( MaybeErr(..) )
133 import qualified GHC.Data.EnumSet as EnumSet
134
135 import qualified Language.Haskell.TH as TH
136 -- THSyntax gives access to internal functions and data types
137 import qualified Language.Haskell.TH.Syntax as TH
138
139 #if defined(HAVE_INTERNAL_INTERPRETER)
140 -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
141 import GHC.Desugar ( AnnotationWrapper(..) )
142 import Unsafe.Coerce ( unsafeCoerce )
143 #endif
144
145 import Control.Monad
146 import Data.Binary
147 import Data.Binary.Get
148 import Data.List ( find )
149 import Data.Maybe
150 import qualified Data.ByteString as B
151 import qualified Data.ByteString.Lazy as LB
152 import Data.Dynamic ( fromDynamic, toDyn )
153 import qualified Data.IntMap as IntMap
154 import qualified Data.Map as Map
155 import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )
156 import Data.Data (Data)
157 import Data.Proxy ( Proxy (..) )
158
159 {-
160 ************************************************************************
161 * *
162 \subsection{Main interface + stubs for the non-GHCI case
163 * *
164 ************************************************************************
165 -}
166
167 tcTypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
168 tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType
169 -> TcM (HsExpr GhcTc)
170 tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
171 -- None of these functions add constraints to the LIE
172
173 -- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
174 -- runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName)
175 -- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)
176 -- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
177
178 runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
179 {-
180 ************************************************************************
181 * *
182 \subsection{Quoting an expression}
183 * *
184 ************************************************************************
185 -}
186
187 -- See Note [How brackets and nested splices are handled]
188 -- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
189 tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
190 = addErrCtxt (quotationCtxtDoc brack) $
191 do { cur_stage <- getStage
192 ; ps_ref <- newMutVar []
193 ; lie_var <- getConstraintVar -- Any constraints arising from nested splices
194 -- should get thrown into the constraint set
195 -- from outside the bracket
196
197 -- Make a new type variable for the type of the overall quote
198 ; m_var <- mkTyVarTy <$> mkMetaTyVar
199 -- Make sure the type variable satisfies Quote
200 ; ev_var <- emitQuoteWanted m_var
201 -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring
202 -- brackets.
203 ; let wrapper = QuoteWrapper ev_var m_var
204 -- Typecheck expr to make sure it is valid,
205 -- Throw away the typechecked expression but return its type.
206 -- We'll typecheck it again when we splice it in somewhere
207 ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $
208 tcScalingUsage Many $
209 -- Scale by Many, TH lifting is currently nonlinear (#18465)
210 tcInferRhoNC expr
211 -- NC for no context; tcBracket does that
212 ; let rep = getRuntimeRep expr_ty
213 ; meta_ty <- tcTExpTy m_var expr_ty
214 ; ps' <- readMutVar ps_ref
215 ; codeco <- tcLookupId unsafeCodeCoerceName
216 ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName
217 ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
218 rn_expr
219 (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)
220 (nlHsTyApp codeco [rep, expr_ty]))
221 (noLocA (HsTcBracketOut bracket_ty (Just wrapper) brack ps'))))
222 meta_ty res_ty }
223 tcTypedBracket _ other_brack _
224 = pprPanic "tcTypedBracket" (ppr other_brack)
225
226 -- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)
227 -- See Note [Typechecking Overloaded Quotes]
228 tcUntypedBracket rn_expr brack ps res_ty
229 = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
230
231
232 -- Create the type m Exp for expression bracket, m Type for a type
233 -- bracket and so on. The brack_info is a Maybe because the
234 -- VarBracket ('a) isn't overloaded, but also shouldn't contain any
235 -- splices.
236 ; (brack_info, expected_type) <- brackTy brack
237
238 -- Match the expected type with the type of all the internal
239 -- splices. They might have further constrained types and if they do
240 -- we want to reflect that in the overall type of the bracket.
241 ; ps' <- case quoteWrapperTyVarTy <$> brack_info of
242 Just m_var -> mapM (tcPendingSplice m_var) ps
243 Nothing -> assert (null ps) $ return []
244
245 ; traceTc "tc_bracket done untyped" (ppr expected_type)
246
247 -- Unify the overall type of the bracket with the expected result
248 -- type
249 ; tcWrapResultO BracketOrigin rn_expr
250 (HsTcBracketOut expected_type brack_info brack ps')
251 expected_type res_ty
252
253 }
254
255 -- | A type variable with kind * -> * named "m"
256 mkMetaTyVar :: TcM TyVar
257 mkMetaTyVar =
258 newNamedFlexiTyVar (fsLit "m") (mkVisFunTyMany liftedTypeKind liftedTypeKind)
259
260
261 -- | For a type 'm', emit the constraint 'Quote m'.
262 emitQuoteWanted :: Type -> TcM EvVar
263 emitQuoteWanted m_var = do
264 quote_con <- tcLookupTyCon quoteClassName
265 emitWantedEvVar BracketOrigin $
266 mkTyConApp quote_con [m_var]
267
268 ---------------
269 -- | Compute the expected type of a quotation, and also the QuoteWrapper in
270 -- the case where it is an overloaded quotation. All quotation forms are
271 -- overloaded aprt from Variable quotations ('foo)
272 brackTy :: HsBracket GhcRn -> TcM (Maybe QuoteWrapper, Type)
273 brackTy b =
274 let mkTy n = do
275 -- New polymorphic type variable for the bracket
276 m_var <- mkTyVarTy <$> mkMetaTyVar
277 -- Emit a Quote constraint for the bracket
278 ev_var <- emitQuoteWanted m_var
279 -- Construct the final expected type of the quote, for example
280 -- m Exp or m Type
281 final_ty <- mkAppTy m_var <$> tcMetaTy n
282 -- Return the evidence variable and metavariable to be used during
283 -- desugaring.
284 let wrapper = QuoteWrapper ev_var m_var
285 return (Just wrapper, final_ty)
286 in
287 case b of
288 (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName
289 -- Result type is Var (not Quote-monadic)
290 (ExpBr {}) -> mkTy expTyConName -- Result type is m Exp
291 (TypBr {}) -> mkTy typeTyConName -- Result type is m Type
292 (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec]
293 (PatBr {}) -> mkTy patTyConName -- Result type is m Pat
294 (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL"
295 (TExpBr {}) -> panic "tcUntypedBracket: Unexpected TExpBr"
296
297 ---------------
298 -- | Typechecking a pending splice from a untyped bracket
299 tcPendingSplice :: TcType -- Metavariable for the expected overall type of the
300 -- quotation.
301 -> PendingRnSplice
302 -> TcM PendingTcSplice
303 tcPendingSplice m_var (PendingRnSplice flavour splice_name expr)
304 -- See Note [Typechecking Overloaded Quotes]
305 = do { meta_ty <- tcMetaTy meta_ty_name
306 -- Expected type of splice, e.g. m Exp
307 ; let expected_type = mkAppTy m_var meta_ty
308 ; expr' <- tcScalingUsage Many $ tcCheckPolyExpr expr expected_type
309 -- Scale by Many, TH lifting is currently nonlinear (#18465)
310 ; return (PendingTcSplice splice_name expr') }
311 where
312 meta_ty_name = case flavour of
313 UntypedExpSplice -> expTyConName
314 UntypedPatSplice -> patTyConName
315 UntypedTypeSplice -> typeTyConName
316 UntypedDeclSplice -> decsTyConName
317
318 ---------------
319 -- Takes a m and tau and returns the type m (TExp tau)
320 tcTExpTy :: TcType -> TcType -> TcM TcType
321 tcTExpTy m_ty exp_ty
322 = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)
323 ; codeCon <- tcLookupTyCon codeTyConName
324 ; let rep = getRuntimeRep exp_ty
325 ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) }
326 where
327 err_msg ty
328 = TcRnUnknownMessage $ mkPlainError noHints $
329 vcat [ text "Illegal polytype:" <+> ppr ty
330 , text "The type of a Typed Template Haskell expression must" <+>
331 text "not have any quantification." ]
332
333 quotationCtxtDoc :: HsBracket GhcRn -> SDoc
334 quotationCtxtDoc br_body
335 = hang (text "In the Template Haskell quotation")
336 2 (ppr br_body)
337
338
339 -- The whole of the rest of the file is the else-branch (ie stage2 only)
340
341 {-
342 Note [How top-level splices are handled]
343 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
344 Top-level splices (those not inside a [| .. |] quotation bracket) are handled
345 very straightforwardly:
346
347 1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
348
349 2. runMetaT: desugar, compile, run it, and convert result back to
350 GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName,
351 HsExpr RdrName etc)
352
353 3. treat the result as if that's what you saw in the first place
354 e.g for HsType, rename and kind-check
355 for HsExpr, rename and type-check
356
357 (The last step is different for decls, because they can *only* be
358 top-level: we return the result of step 2.)
359
360 Note [How brackets and nested splices are handled]
361 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
362 Nested splices (those inside a [| .. |] quotation bracket),
363 are treated quite differently.
364
365 Remember, there are two forms of bracket
366 typed [|| e ||]
367 and untyped [| e |]
368
369 The life cycle of a typed bracket:
370 * Starts as HsBracket
371
372 * When renaming:
373 * Set the ThStage to (Brack s RnPendingTyped)
374 * Rename the body
375 * Result is still a HsBracket
376
377 * When typechecking:
378 * Set the ThStage to (Brack s (TcPending ps_var lie_var))
379 * Typecheck the body, and throw away the elaborated result
380 * Nested splices (which must be typed) are typechecked, and
381 the results accumulated in ps_var; their constraints
382 accumulate in lie_var
383 * Result is a HsTcBracketOut rn_brack pending_splices
384 where rn_brack is the incoming renamed bracket
385
386 The life cycle of a un-typed bracket:
387 * Starts as HsBracket
388
389 * When renaming:
390 * Set the ThStage to (Brack s (RnPendingUntyped ps_var))
391 * Rename the body
392 * Nested splices (which must be untyped) are renamed, and the
393 results accumulated in ps_var
394 * Result is still (HsRnBracketOut rn_body pending_splices)
395
396 * When typechecking a HsRnBracketOut
397 * Typecheck the pending_splices individually
398 * Ignore the body of the bracket; just check that the context
399 expects a bracket of that type (e.g. a [p| pat |] bracket should
400 be in a context needing a (Q Pat)
401 * Result is a HsTcBracketOut rn_brack pending_splices
402 where rn_brack is the incoming renamed bracket
403
404
405 In both cases, desugaring happens like this:
406 * HsTcBracketOut is desugared by GHC.HsToCore.Quote.dsBracket. It
407
408 a) Extends the ds_meta environment with the PendingSplices
409 attached to the bracket
410
411 b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
412 run, will produce a suitable TH expression/type/decl. This
413 is why we leave the *renamed* expression attached to the bracket:
414 the quoted expression should not be decorated with all the goop
415 added by the type checker
416
417 * Each splice carries a unique Name, called a "splice point", thus
418 ${n}(e). The name is initialised to an (Unqual "splice") when the
419 splice is created; the renamer gives it a unique.
420
421 * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across
422 a splice, it looks up the splice's Name, n, in the ds_meta envt,
423 to find an (HsExpr Id) that should be substituted for the splice;
424 it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice).
425
426 Example:
427 Source: f = [| Just $(g 3) |]
428 The [| |] part is a HsBracket
429
430 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
431 The [| |] part is a HsBracketOut, containing *renamed*
432 (not typechecked) expression
433 The "s7" is the "splice point"; the (g Int 3) part
434 is a typechecked expression
435
436 Desugared: f = do { s7 <- g Int 3
437 ; return (ConE "Data.Maybe.Just" s7) }
438
439
440 Note [Template Haskell state diagram]
441 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
442 Here are the ThStages, s, their corresponding level numbers
443 (the result of (thLevel s)), and their state transitions.
444 The top level of the program is stage Comp:
445
446 Start here
447 |
448 V
449 ----------- $ ------------ $
450 | Comp | ---------> | Splice | -----|
451 | 1 | | 0 | <----|
452 ----------- ------------
453 ^ | ^ |
454 $ | | [||] $ | | [||]
455 | v | v
456 -------------- ----------------
457 | Brack Comp | | Brack Splice |
458 | 2 | | 1 |
459 -------------- ----------------
460
461 * Normal top-level declarations start in state Comp
462 (which has level 1).
463 Annotations start in state Splice, since they are
464 treated very like a splice (only without a '$')
465
466 * Code compiled in state Splice (and only such code)
467 will be *run at compile time*, with the result replacing
468 the splice
469
470 * The original paper used level -1 instead of 0, etc.
471
472 * The original paper did not allow a splice within a
473 splice, but there is no reason not to. This is the
474 $ transition in the top right.
475
476 Note [Template Haskell levels]
477 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
478 * Imported things are impLevel (= 0)
479
480 * However things at level 0 are not *necessarily* imported.
481 eg $( \b -> ... ) here b is bound at level 0
482
483 * In GHCi, variables bound by a previous command are treated
484 as impLevel, because we have bytecode for them.
485
486 * Variables are bound at the "current level"
487
488 * The current level starts off at outerLevel (= 1)
489
490 * The level is decremented by splicing $(..)
491 incremented by brackets [| |]
492 incremented by name-quoting 'f
493
494 * When a variable is used, checkWellStaged compares
495 bind: binding level, and
496 use: current level at usage site
497
498 Generally
499 bind > use Always error (bound later than used)
500 [| \x -> $(f x) |]
501
502 bind = use Always OK (bound same stage as used)
503 [| \x -> $(f [| x |]) |]
504
505 bind < use Inside brackets, it depends
506 Inside splice, OK
507 Inside neither, OK
508
509 For (bind < use) inside brackets, there are three cases:
510 - Imported things OK f = [| map |]
511 - Top-level things OK g = [| f |]
512 - Non-top-level Only if there is a liftable instance
513 h = \(x:Int) -> [| x |]
514
515 To track top-level-ness we use the ThBindEnv in TcLclEnv
516
517 For example:
518 f = ...
519 g1 = $(map ...) is OK
520 g2 = $(f ...) is not OK; because we haven't compiled f yet
521
522 Note [Typechecking Overloaded Quotes]
523 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
524
525 The main function for typechecking untyped quotations is `tcUntypedBracket`.
526
527 Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`.
528 When we typecheck it we therefore create a template of a metavariable `m` applied to `Exp` and
529 emit a constraint `Quote m`. All this is done in the `brackTy` function.
530 `brackTy` also selects the correct contents type for the quotation (Exp, Type, Decs etc).
531
532 The meta variable and the constraint evidence variable are
533 returned together in a `QuoteWrapper` and then passed along to two further places
534 during compilation:
535
536 1. Typechecking nested splices (immediately in tcPendingSplice)
537 2. Desugaring quotations (see GHC.HsToCore.Quote)
538
539 `tcPendingSplice` takes the `m` type variable as an argument and checks
540 each nested splice against this variable `m`. During this
541 process the variable `m` can either be fixed to a specific value or further constrained by the
542 nested splices.
543
544 Once we have checked all the nested splices, the quote type is checked against
545 the expected return type.
546
547 The process is very simple and like typechecking a list where the quotation is
548 like the container and the splices are the elements of the list which must have
549 a specific type.
550
551 After the typechecking process is completed, the evidence variable for `Quote m`
552 and the type `m` is stored in a `QuoteWrapper` which is passed through the pipeline
553 and used when desugaring quotations.
554
555 Typechecking typed quotations is a similar idea but the `QuoteWrapper` is stored
556 in the `PendingStuff` as the nested splices are gathered up in a different way
557 to untyped splices. Untyped splices are found in the renamer but typed splices are
558 not typechecked and extracted until during typechecking.
559
560 -}
561
562 -- | We only want to produce warnings for TH-splices if the user requests so.
563 -- See Note [Warnings for TH splices].
564 getThSpliceOrigin :: TcM Origin
565 getThSpliceOrigin = do
566 warn <- goptM Opt_EnableThSpliceWarnings
567 if warn then return FromSource else return Generated
568
569 {- Note [Warnings for TH splices]
570 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
571 We only produce warnings for TH splices when the user requests so
572 (-fenable-th-splice-warnings). There are multiple reasons:
573
574 * It's not clear that the user that compiles a splice is the author of the code
575 that produces the warning. Think of the situation where they just splice in
576 code from a third-party library that produces incomplete pattern matches.
577 In this scenario, the user isn't even able to fix that warning.
578 * Gathering information for producing the warnings (pattern-match check
579 warnings in particular) is costly. There's no point in doing so if the user
580 is not interested in those warnings.
581
582 That's why we store Origin flags in the Haskell AST. The functions from ThToHs
583 take such a flag and depending on whether TH splice warnings were enabled or
584 not, we pass FromSource (if the user requests warnings) or Generated
585 (otherwise). This is implemented in getThSpliceOrigin.
586
587 For correct pattern-match warnings it's crucial that we annotate the Origin
588 consistently (#17270). In the future we could offer the Origin as part of the
589 TH AST. That would enable us to give quotes from the current module get
590 FromSource origin, and/or third library authors to tag certain parts of
591 generated code as FromSource to enable warnings.
592 That effort is tracked in #14838.
593 -}
594
595 {-
596 ************************************************************************
597 * *
598 \subsection{Splicing an expression}
599 * *
600 ************************************************************************
601 -}
602
603 tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty
604 = addErrCtxt (spliceCtxtDoc splice) $
605 setSrcSpan (getLocA expr) $ do
606 { stage <- getStage
607 ; case stage of
608 Splice {} -> tcTopSplice expr res_ty
609 Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty
610 RunSplice _ ->
611 -- See Note [RunSplice ThLevel] in "GHC.Tc.Types".
612 pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++
613 "running another splice") (ppr splice)
614 Comp -> tcTopSplice expr res_ty
615 }
616 tcSpliceExpr splice _
617 = pprPanic "tcSpliceExpr" (ppr splice)
618
619 {- Note [Collecting modFinalizers in typed splices]
620 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
621
622 'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local
623 environment (see Note [Delaying modFinalizers in untyped splices] in
624 GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the
625 finalizer list in the global environment and set them to use the current local
626 environment (with 'addModFinalizersWithLclEnv').
627
628 -}
629
630 tcNestedSplice :: ThStage -> PendingStuff -> Name
631 -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
632 -- See Note [How brackets and nested splices are handled]
633 -- A splice inside brackets
634 tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) splice_name expr res_ty
635 = do { res_ty <- expTypeToType res_ty
636 ; let rep = getRuntimeRep res_ty
637 ; meta_exp_ty <- tcTExpTy m_var res_ty
638 ; expr' <- setStage pop_stage $
639 setConstraintVar lie_var $
640 tcCheckMonoExpr expr meta_exp_ty
641 ; untype_code <- tcLookupId unTypeCodeName
642 ; let expr'' = mkHsApp
643 (mkLHsWrap (applyQuoteWrapper q)
644 (nlHsTyApp untype_code [rep, res_ty])) expr'
645 ; ps <- readMutVar ps_var
646 ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
647
648 -- The returned expression is ignored; it's in the pending splices
649 -- But we still return a plausible expression
650 -- (a) in case we print it in debug messages, and
651 -- (b) because we test whether it is tagToEnum in Tc.Gen.Expr.tcApp
652 ; return (HsSpliceE noAnn $
653 HsSpliced noExtField (ThModFinalizers []) $
654 HsSplicedExpr (unLoc expr'')) }
655
656
657 tcNestedSplice _ _ splice_name _ _
658 = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)
659
660 tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
661 tcTopSplice expr res_ty
662 = do { -- Typecheck the expression,
663 -- making sure it has type Q (T res_ty)
664 res_ty <- expTypeToType res_ty
665 ; q_type <- tcMetaTy qTyConName
666 -- Top level splices must still be of type Q (TExp a)
667 ; meta_exp_ty <- tcTExpTy q_type res_ty
668 ; q_expr <- tcTopSpliceExpr Typed $
669 tcCheckMonoExpr expr meta_exp_ty
670 ; lcl_env <- getLclEnv
671 ; let delayed_splice
672 = DelayedSplice lcl_env expr res_ty q_expr
673 ; return (HsSpliceE noAnn (XSplice (HsSplicedT delayed_splice)))
674
675 }
676
677
678 -- This is called in the zonker
679 -- See Note [Running typed splices in the zonker]
680 runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
681 runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)
682 = do
683 errs_var <- getErrsVar
684 setLclEnv lcl_env $ setErrsVar errs_var $ do {
685 -- Set the errs_var to the errs_var from the current context,
686 -- otherwise error messages can go missing in GHCi (#19470)
687 zonked_ty <- zonkTcType res_ty
688 ; zonked_q_expr <- zonkTopLExpr q_expr
689 -- See Note [Collecting modFinalizers in typed splices].
690 ; modfinalizers_ref <- newTcRef []
691 -- Run the expression
692 ; expr2 <- setStage (RunSplice modfinalizers_ref) $
693 runMetaE zonked_q_expr
694 ; mod_finalizers <- readTcRef modfinalizers_ref
695 ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
696 -- We use orig_expr here and not q_expr when tracing as a call to
697 -- unsafeCodeCoerce is added to the original expression by the
698 -- typechecker when typed quotes are type checked.
699 ; traceSplice (SpliceInfo { spliceDescription = "expression"
700 , spliceIsDecl = False
701 , spliceSource = Just orig_expr
702 , spliceGenerated = ppr expr2 })
703 -- Rename and typecheck the spliced-in expression,
704 -- making sure it has type res_ty
705 -- These steps should never fail; this is a *typed* splice
706 ; (res, wcs) <-
707 captureConstraints $
708 addErrCtxt (spliceResultDoc zonked_q_expr) $ do
709 { (exp3, _fvs) <- rnLExpr expr2
710 ; tcCheckMonoExpr exp3 zonked_ty }
711 ; ev <- simplifyTop wcs
712 ; return $ unLoc (mkHsDictLet (EvBinds ev) res)
713 }
714
715
716 {-
717 ************************************************************************
718 * *
719 \subsection{Error messages}
720 * *
721 ************************************************************************
722 -}
723
724 spliceCtxtDoc :: HsSplice GhcRn -> SDoc
725 spliceCtxtDoc splice
726 = hang (text "In the Template Haskell splice")
727 2 (pprSplice splice)
728
729 spliceResultDoc :: LHsExpr GhcTc -> SDoc
730 spliceResultDoc expr
731 = sep [ text "In the result of the splice:"
732 , nest 2 (char '$' <> ppr expr)
733 , text "To see what the splice expanded to, use -ddump-splices"]
734
735 -------------------
736 tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
737 -- Note [How top-level splices are handled]
738 -- Type check an expression that is the body of a top-level splice
739 -- (the caller will compile and run it)
740 -- Note that set the level to Splice, regardless of the original level,
741 -- before typechecking the expression. For example:
742 -- f x = $( ...$(g 3) ... )
743 -- The recursive call to tcCheckPolyExpr will simply expand the
744 -- inner escape before dealing with the outer one
745
746 tcTopSpliceExpr isTypedSplice tc_action
747 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
748 -- if the type checker fails!
749 unsetGOptM Opt_DeferTypeErrors $
750 -- Don't defer type errors. Not only are we
751 -- going to run this code, but we do an unsafe
752 -- coerce, so we get a seg-fault if, say we
753 -- splice a type into a place where an expression
754 -- is expected (#7276)
755 setStage (Splice isTypedSplice) $
756 do { -- Typecheck the expression
757 (mb_expr', wanted) <- tryCaptureConstraints tc_action
758 -- If tc_action fails (perhaps because of insoluble constraints)
759 -- we want to capture and report those constraints, else we may
760 -- just get a silent failure (#20179). Hence the 'try' part.
761
762 ; const_binds <- simplifyTop wanted
763
764 ; case mb_expr' of
765 Nothing -> failM -- In this case simplifyTop should have
766 -- reported some errors
767 Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' }
768
769 {-
770 ************************************************************************
771 * *
772 Annotations
773 * *
774 ************************************************************************
775 -}
776
777 runAnnotation target expr = do
778 -- Find the classes we want instances for in order to call toAnnotationWrapper
779 loc <- getSrcSpanM
780 data_class <- tcLookupClass dataClassName
781 to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
782
783 -- Check the instances we require live in another module (we want to execute it..)
784 -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
785 -- also resolves the LIE constraints to detect e.g. instance ambiguity
786 zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped (
787 do { (expr', expr_ty) <- tcInferRhoNC expr
788 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
789 -- By instantiating the call >here< it gets registered in the
790 -- LIE consulted by tcTopSpliceExpr
791 -- and hence ensures the appropriate dictionary is bound by const_binds
792 ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
793 ; let loc' = noAnnSrcSpan loc
794 ; let specialised_to_annotation_wrapper_expr
795 = L loc' (mkHsWrap wrapper
796 (HsVar noExtField (L (noAnnSrcSpan loc) to_annotation_wrapper_id)))
797 ; return (L loc' (HsApp noComments
798 specialised_to_annotation_wrapper_expr expr'))
799 })
800
801 -- Run the appropriately wrapped expression to get the value of
802 -- the annotation and its dictionaries. The return value is of
803 -- type AnnotationWrapper by construction, so this conversion is
804 -- safe
805 serialized <- runMetaAW zonked_wrapped_expr'
806 return Annotation {
807 ann_target = target,
808 ann_value = serialized
809 }
810
811 convertAnnotationWrapper :: ForeignHValue -> TcM (Either SDoc Serialized)
812 convertAnnotationWrapper fhv = do
813 interp <- tcGetInterp
814 case interpInstance interp of
815 ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv
816 #if defined(HAVE_INTERNAL_INTERPRETER)
817 InternalInterp -> do
818 annotation_wrapper <- liftIO $ wormhole interp fhv
819 return $ Right $
820 case unsafeCoerce annotation_wrapper of
821 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
822 -- Got the value and dictionaries: build the serialized value and
823 -- call it a day. We ensure that we seq the entire serialized value
824 -- in order that any errors in the user-written code for the
825 -- annotation are exposed at this point. This is also why we are
826 -- doing all this stuff inside the context of runMeta: it has the
827 -- facilities to deal with user error in a meta-level expression
828 seqSerialized serialized `seq` serialized
829
830 -- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
831 seqSerialized :: Serialized -> ()
832 seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
833
834 #endif
835
836 {-
837 ************************************************************************
838 * *
839 \subsection{Running an expression}
840 * *
841 ************************************************************************
842 -}
843
844 runQuasi :: TH.Q a -> TcM a
845 runQuasi act = TH.runQ act
846
847 runRemoteModFinalizers :: ThModFinalizers -> TcM ()
848 runRemoteModFinalizers (ThModFinalizers finRefs) = do
849 let withForeignRefs [] f = f []
850 withForeignRefs (x : xs) f = withForeignRef x $ \r ->
851 withForeignRefs xs $ \rs -> f (r : rs)
852 interp <- tcGetInterp
853 case interpInstance interp of
854 #if defined(HAVE_INTERNAL_INTERPRETER)
855 InternalInterp -> do
856 qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
857 runQuasi $ sequence_ qs
858 #endif
859
860 ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> do
861 tcg <- getGblEnv
862 th_state <- readTcRef (tcg_th_remote_state tcg)
863 case th_state of
864 Nothing -> return () -- TH was not started, nothing to do
865 Just fhv -> do
866 liftIO $ withForeignRef fhv $ \st ->
867 withForeignRefs finRefs $ \qrefs ->
868 writeIServ i (putMessage (RunModFinalizers st qrefs))
869 () <- runRemoteTH i []
870 readQResult i
871
872 runQResult
873 :: (a -> String)
874 -> (Origin -> SrcSpan -> a -> b)
875 -> (ForeignHValue -> TcM a)
876 -> SrcSpan
877 -> ForeignHValue {- TH.Q a -}
878 -> TcM b
879 runQResult show_th f runQ expr_span hval
880 = do { th_result <- runQ hval
881 ; th_origin <- getThSpliceOrigin
882 ; traceTc "Got TH result:" (text (show_th th_result))
883 ; return (f th_origin expr_span th_result) }
884
885
886 -----------------
887 runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn)
888 -> LHsExpr GhcTc
889 -> TcM hs_syn
890 runMeta unwrap e = do
891 hooks <- getHooks
892 case runMetaHook hooks of
893 Nothing -> unwrap defaultRunMeta e
894 Just h -> unwrap h e
895
896 defaultRunMeta :: MetaHook TcM
897 defaultRunMeta (MetaE r)
898 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)
899 defaultRunMeta (MetaP r)
900 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)
901 defaultRunMeta (MetaT r)
902 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)
903 defaultRunMeta (MetaD r)
904 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)
905 defaultRunMeta (MetaAW r)
906 = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)
907 -- We turn off showing the code in meta-level exceptions because doing so exposes
908 -- the toAnnotationWrapper function that we slap around the user's code
909
910 ----------------
911 runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper
912 -> TcM Serialized
913 runMetaAW = runMeta metaRequestAW
914
915 runMetaE :: LHsExpr GhcTc -- Of type (Q Exp)
916 -> TcM (LHsExpr GhcPs)
917 runMetaE = runMeta metaRequestE
918
919 runMetaP :: LHsExpr GhcTc -- Of type (Q Pat)
920 -> TcM (LPat GhcPs)
921 runMetaP = runMeta metaRequestP
922
923 runMetaT :: LHsExpr GhcTc -- Of type (Q Type)
924 -> TcM (LHsType GhcPs)
925 runMetaT = runMeta metaRequestT
926
927 runMetaD :: LHsExpr GhcTc -- Of type Q [Dec]
928 -> TcM [LHsDecl GhcPs]
929 runMetaD = runMeta metaRequestD
930
931 {- Note [Errors in desugaring a splice]
932 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
933 What should we do if there are errors when desugaring a splice? We should
934 abort. There are several cases to consider:
935
936 (a) The desugarer hits an unrecoverable error and fails in the monad.
937 (b) The desugarer hits a recoverable error, reports it, and continues.
938 (c) The desugarer reports a fatal warning (with -Werror), reports it, and continues.
939 (d) The desugarer reports a non-fatal warning, and continues.
940
941 Each case is tested in th/T19709[abcd].
942
943 General principle: we wish to report all messages from dealing with a splice
944 eagerly, as these messages arise during an earlier stage than type-checking
945 generally. It's also likely that a compile-time warning from spliced code
946 will be easier to understand then an error that arises from processing the
947 code the splice produces. (Rationale: the warning will be about the code the
948 user actually wrote, not what is generated.)
949
950 Case (a): We have no choice but to abort here, but we must make sure that
951 the messages are printed or logged before aborting. Logging them is annoying,
952 because we're in the type-checker, and the messages are DsMessages, from the
953 desugarer. So we report and then fail in the monad. This case is detected
954 by the fact that initDsTc returns Nothing.
955
956 Case (b): We detect this case by looking for errors in the messages returned
957 from initDsTc and aborting if we spot any (after printing, of course). Note
958 that initDsTc will return a Just ds_expr in this case, but we don't wish to
959 use the (likely very bogus) expression.
960
961 Case (c): This is functionally the same as (b), except that the expression
962 isn't bogus. We still don't wish to use it, as the user's request for -Werror
963 tells us not to.
964
965 Case (d): We report the warnings and then carry on with the expression.
966 This might result in warnings printed out of source order, but this is
967 appropriate, as the warnings from the splice arise from an earlier stage
968 of compilation.
969
970 Previously, we failed to abort in cases (b) and (c), leading to #19709.
971 -}
972
973 ---------------
974 runMeta' :: Bool -- Whether code should be printed in the exception message
975 -> (hs_syn -> SDoc) -- how to print the code
976 -> (SrcSpan -> ForeignHValue -> TcM (Either SDoc hs_syn)) -- How to run x
977 -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or
978 -- something like that
979 -> TcM hs_syn -- Of type t
980 runMeta' show_code ppr_hs run_and_convert expr
981 = do { traceTc "About to run" (ppr expr)
982 ; recordThSpliceUse -- seems to be the best place to do this,
983 -- we catch all kinds of splices and annotations.
984
985 -- Check that we've had no errors of any sort so far.
986 -- For example, if we found an error in an earlier defn f, but
987 -- recovered giving it type f :: forall a.a, it'd be very dodgy
988 -- to carry on. Mind you, the staging restrictions mean we won't
989 -- actually run f, but it still seems wrong. And, more concretely,
990 -- see #5358 for an example that fell over when trying to
991 -- reify a function with a "?" kind in it. (These don't occur
992 -- in type-correct programs.)
993 ; failIfErrsM
994
995 -- run plugins
996 ; hsc_env <- getTopEnv
997 ; expr' <- withPlugins hsc_env spliceRunAction expr
998
999 -- Desugar
1000 ; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr')
1001
1002 -- Print any messages (even warnings) eagerly: they might be helpful if anything
1003 -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all
1004 -- cases.
1005 ; logger <- getLogger
1006 ; diag_opts <- initDiagOpts <$> getDynFlags
1007 ; liftIO $ printMessages logger diag_opts ds_msgs
1008
1009 ; ds_expr <- case mb_ds_expr of
1010 Nothing -> failM -- Case (a) from Note [Errors in desugaring a splice]
1011 Just ds_expr -> -- There still might be a fatal warning or recoverable
1012 -- Cases (b) and (c) from Note [Errors in desugaring a splice]
1013 do { when (errorsOrFatalWarningsFound ds_msgs)
1014 failM
1015 ; return ds_expr }
1016
1017 -- Compile and link it; might fail if linking fails
1018 ; src_span <- getSrcSpanM
1019 ; mnwib <- getMnwib
1020 ; traceTc "About to run (desugared)" (ppr ds_expr)
1021 ; either_hval <- tryM $ liftIO $
1022 GHC.Driver.Main.hscCompileCoreExpr hsc_env (src_span, Just mnwib) ds_expr
1023 ; case either_hval of {
1024 Left exn -> fail_with_exn "compile and link" exn ;
1025 Right hval -> do
1026
1027 { -- Coerce it to Q t, and run it
1028
1029 -- Running might fail if it throws an exception of any kind (hence tryAllM)
1030 -- including, say, a pattern-match exception in the code we are running
1031 --
1032 -- We also do the TH -> HS syntax conversion inside the same
1033 -- exception-catching thing so that if there are any lurking
1034 -- exceptions in the data structure returned by hval, we'll
1035 -- encounter them inside the try
1036 --
1037 -- See Note [Exceptions in TH]
1038 let expr_span = getLocA expr
1039 ; either_tval <- tryAllM $
1040 setSrcSpan expr_span $ -- Set the span so that qLocation can
1041 -- see where this splice is
1042 do { mb_result <- run_and_convert expr_span hval
1043 ; case mb_result of
1044 Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)
1045 Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
1046 ; return $! result } }
1047
1048 ; case either_tval of
1049 Right v -> return v
1050 Left se -> case fromException se of
1051 Just IOEnvFailure -> failM -- Error already in Tc monad
1052 _ -> fail_with_exn "run" se -- Exception
1053 }}}
1054 where
1055 -- see Note [Concealed TH exceptions]
1056 fail_with_exn :: Exception e => String -> e -> TcM a
1057 fail_with_exn phase exn = do
1058 exn_msg <- liftIO $ Panic.safeShowException exn
1059 let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
1060 nest 2 (text exn_msg),
1061 if show_code then text "Code:" <+> ppr expr else empty]
1062 failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)
1063
1064 {-
1065 Note [Running typed splices in the zonker]
1066 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1067
1068 See #15471 for the full discussion.
1069
1070 For many years typed splices were run immediately after they were type checked
1071 however, this is too early as it means to zonk some type variables before
1072 they can be unified with type variables in the surrounding context.
1073
1074 For example,
1075
1076 ```
1077 module A where
1078
1079 test_foo :: forall a . Q (TExp (a -> a))
1080 test_foo = [|| id ||]
1081
1082 module B where
1083
1084 import A
1085
1086 qux = $$(test_foo)
1087 ```
1088
1089 We would expect `qux` to have inferred type `forall a . a -> a` but if
1090 we run the splices too early the unified variables are zonked to `Any`. The
1091 inferred type is the unusable `Any -> Any`.
1092
1093 To run the splice, we must compile `test_foo` all the way to byte code.
1094 But at the moment when the type checker is looking at the splice, test_foo
1095 has type `Q (TExp (alpha -> alpha))` and we
1096 certainly can't compile code involving unification variables!
1097
1098 We could default `alpha` to `Any` but then we infer `qux :: Any -> Any`
1099 which definitely is not what we want. Moreover, if we had
1100 qux = [$$(test_foo), (\x -> x +1::Int)]
1101 then `alpha` would have to be `Int`.
1102
1103 Conclusion: we must defer taking decisions about `alpha` until the
1104 typechecker is done; and *then* we can run the splice. It's fine to do it
1105 later, because we know it'll produce type-correct code.
1106
1107 Deferring running the splice until later, in the zonker, means that the
1108 unification variables propagate upwards from the splice into the surrounding
1109 context and are unified correctly.
1110
1111 This is implemented by storing the arguments we need for running the splice
1112 in a `DelayedSplice`. In the zonker, the arguments are passed to
1113 `GHC.Tc.Gen.Splice.runTopSplice` and the expression inserted into the AST as normal.
1114
1115
1116
1117 Note [Exceptions in TH]
1118 ~~~~~~~~~~~~~~~~~~~~~~~
1119 Suppose we have something like this
1120 $( f 4 )
1121 where
1122 f :: Int -> Q [Dec]
1123 f n | n>3 = fail "Too many declarations"
1124 | otherwise = ...
1125
1126 The 'fail' is a user-generated failure, and should be displayed as a
1127 perfectly ordinary compiler error message, not a panic or anything
1128 like that. Here's how it's processed:
1129
1130 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
1131 effectively transforms (fail s) to
1132 qReport True s >> fail
1133 where 'qReport' comes from the Quasi class and fail from its monad
1134 superclass.
1135
1136 * The TcM monad is an instance of Quasi (see GHC.Tc.Gen.Splice), and it implements
1137 (qReport True s) by using addErr to add an error message to the bag of errors.
1138 The 'fail' in TcM raises an IOEnvFailure exception
1139
1140 * 'qReport' forces the message to ensure any exception hidden in unevaluated
1141 thunk doesn't get into the bag of errors. Otherwise the following splice
1142 will trigger panic (#8987):
1143 $(fail undefined)
1144 See also Note [Concealed TH exceptions]
1145
1146 * So, when running a splice, we catch all exceptions; then for
1147 - an IOEnvFailure exception, we assume the error is already
1148 in the error-bag (above)
1149 - other errors, we add an error to the bag
1150 and then fail
1151
1152 Note [Concealed TH exceptions]
1153 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1154 When displaying the error message contained in an exception originated from TH
1155 code, we need to make sure that the error message itself does not contain an
1156 exception. For example, when executing the following splice:
1157
1158 $( error ("foo " ++ error "bar") )
1159
1160 the message for the outer exception is a thunk which will throw the inner
1161 exception when evaluated.
1162
1163 For this reason, we display the message of a TH exception using the
1164 'safeShowException' function, which recursively catches any exception thrown
1165 when showing an error message.
1166
1167
1168 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
1169 -}
1170
1171 instance TH.Quasi TcM where
1172 qNewName s = do { u <- newUnique
1173 ; let i = toInteger (getKey u)
1174 ; return (TH.mkNameU s i) }
1175
1176 -- 'msg' is forced to ensure exceptions don't escape,
1177 -- see Note [Exceptions in TH]
1178 qReport True msg = seqList msg $ addErr $ TcRnUnknownMessage $ mkPlainError noHints (text msg)
1179 qReport False msg = seqList msg $ addDiagnostic $ TcRnUnknownMessage $
1180 mkPlainDiagnostic WarningWithoutFlag noHints (text msg)
1181
1182 qLocation = do { m <- getModule
1183 ; l <- getSrcSpanM
1184 ; r <- case l of
1185 UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
1186 (ppr l)
1187 RealSrcSpan s _ -> return s
1188 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
1189 , TH.loc_module = moduleNameString (moduleName m)
1190 , TH.loc_package = unitString (moduleUnit m)
1191 , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
1192 , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
1193
1194 qLookupName = lookupName
1195 qReify = reify
1196 qReifyFixity nm = lookupThName nm >>= reifyFixity
1197 qReifyType = reifyTypeOfThing
1198 qReifyInstances = reifyInstances
1199 qReifyRoles = reifyRoles
1200 qReifyAnnotations = reifyAnnotations
1201 qReifyModule = reifyModule
1202 qReifyConStrictness nm = do { nm' <- lookupThName nm
1203 ; dc <- tcLookupDataCon nm'
1204 ; let bangs = dataConImplBangs dc
1205 ; return (map reifyDecidedStrictness bangs) }
1206
1207 -- For qRecover, discard error messages if
1208 -- the recovery action is chosen. Otherwise
1209 -- we'll only fail higher up.
1210 qRecover recover main = tryTcDiscardingErrs recover main
1211
1212 qAddDependentFile fp = do
1213 ref <- fmap tcg_dependent_files getGblEnv
1214 dep_files <- readTcRef ref
1215 writeTcRef ref (fp:dep_files)
1216
1217 qAddTempFile suffix = do
1218 dflags <- getDynFlags
1219 logger <- getLogger
1220 tmpfs <- hsc_tmpfs <$> getTopEnv
1221 liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
1222
1223 qAddTopDecls thds = do
1224 l <- getSrcSpanM
1225 th_origin <- getThSpliceOrigin
1226 let either_hval = convertToHsDecls th_origin l thds
1227 ds <- case either_hval of
1228 Left exn -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
1229 hang (text "Error in a declaration passed to addTopDecls:")
1230 2 exn
1231 Right ds -> return ds
1232 mapM_ (checkTopDecl . unLoc) ds
1233 th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
1234 updTcRef th_topdecls_var (\topds -> ds ++ topds)
1235 where
1236 checkTopDecl :: HsDecl GhcPs -> TcM ()
1237 checkTopDecl (ValD _ binds)
1238 = mapM_ bindName (collectHsBindBinders CollNoDictBinders binds)
1239 checkTopDecl (SigD _ _)
1240 = return ()
1241 checkTopDecl (AnnD _ _)
1242 = return ()
1243 checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))
1244 = bindName name
1245 checkTopDecl _
1246 = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
1247 text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"
1248
1249 bindName :: RdrName -> TcM ()
1250 bindName (Exact n)
1251 = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
1252 ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
1253 }
1254
1255 bindName name =
1256 addErr $ TcRnUnknownMessage $ mkPlainError noHints $
1257 hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.")
1258 2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
1259
1260 qAddForeignFilePath lang fp = do
1261 var <- fmap tcg_th_foreign_files getGblEnv
1262 updTcRef var ((lang, fp) :)
1263
1264 qAddModFinalizer fin = do
1265 r <- liftIO $ mkRemoteRef fin
1266 fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
1267 addModFinalizerRef fref
1268
1269 qAddCorePlugin plugin = do
1270 hsc_env <- getTopEnv
1271 let fc = hsc_FC hsc_env
1272 let home_unit = hsc_home_unit hsc_env
1273 let dflags = hsc_dflags hsc_env
1274 let fopts = initFinderOpts dflags
1275 r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
1276 let err = hang
1277 (text "addCorePlugin: invalid plugin module "
1278 <+> text (show plugin)
1279 )
1280 2
1281 (text "Plugins in the current package can't be specified.")
1282 case r of
1283 Found {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err
1284 FoundMultiple {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err
1285 _ -> return ()
1286 th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
1287 updTcRef th_coreplugins_var (plugin:)
1288
1289 qGetQ :: forall a. Typeable a => TcM (Maybe a)
1290 qGetQ = do
1291 th_state_var <- fmap tcg_th_state getGblEnv
1292 th_state <- readTcRef th_state_var
1293 -- See #10596 for why we use a scoped type variable here.
1294 return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
1295
1296 qPutQ x = do
1297 th_state_var <- fmap tcg_th_state getGblEnv
1298 updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
1299
1300 qIsExtEnabled = xoptM
1301
1302 qExtsEnabled =
1303 EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
1304
1305 qPutDoc doc_loc s = do
1306 th_doc_var <- tcg_th_docs <$> getGblEnv
1307 resolved_doc_loc <- resolve_loc doc_loc
1308 is_local <- checkLocalName resolved_doc_loc
1309 unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text
1310 "Can't add documentation to" <+> ppr_loc doc_loc <+>
1311 text "as it isn't inside the current module"
1312 updTcRef th_doc_var (Map.insert resolved_doc_loc s)
1313 where
1314 resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n
1315 resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i
1316 resolve_loc (TH.InstDoc t) = InstDoc <$> fmap getName (lookupThInstName t)
1317 resolve_loc TH.ModuleDoc = pure ModuleDoc
1318
1319 ppr_loc (TH.DeclDoc n) = ppr_th n
1320 ppr_loc (TH.ArgDoc n _) = ppr_th n
1321 ppr_loc (TH.InstDoc t) = ppr_th t
1322 ppr_loc TH.ModuleDoc = text "the module header"
1323
1324 -- It doesn't make sense to add documentation to something not inside
1325 -- the current module. So check for it!
1326 checkLocalName (DeclDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
1327 checkLocalName (ArgDoc n _) = nameIsLocalOrFrom <$> getModule <*> pure n
1328 checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
1329 checkLocalName ModuleDoc = pure True
1330
1331
1332 qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
1333 qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
1334 qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
1335 qGetDoc TH.ModuleDoc = do
1336 (moduleDoc, _, _) <- getGblEnv >>= extractDocs
1337 return (fmap unpackHDS moduleDoc)
1338
1339 -- | Looks up documentation for a declaration in first the current module,
1340 -- otherwise tries to find it in another module via 'hscGetModuleInterface'.
1341 lookupDeclDoc :: Name -> TcM (Maybe String)
1342 lookupDeclDoc nm = do
1343 (_, DeclDocMap declDocs, _) <- getGblEnv >>= extractDocs
1344 fam_insts <- tcg_fam_insts <$> getGblEnv
1345 traceTc "lookupDeclDoc" (ppr nm <+> ppr declDocs <+> ppr fam_insts)
1346 case Map.lookup nm declDocs of
1347 Just doc -> pure $ Just (unpackHDS doc)
1348 Nothing -> do
1349 -- Wasn't in the current module. Try searching other external ones!
1350 mIface <- getExternalModIface nm
1351 case mIface of
1352 Nothing -> pure Nothing
1353 Just ModIface { mi_decl_docs = DeclDocMap dmap } ->
1354 pure $ unpackHDS <$> Map.lookup nm dmap
1355
1356 -- | Like 'lookupDeclDoc', looks up documentation for a function argument. If
1357 -- it can't find any documentation for a function in this module, it tries to
1358 -- find it in another module.
1359 lookupArgDoc :: Int -> Name -> TcM (Maybe String)
1360 lookupArgDoc i nm = do
1361 (_, _, ArgDocMap argDocs) <- getGblEnv >>= extractDocs
1362 case Map.lookup nm argDocs of
1363 Just m -> pure $ unpackHDS <$> IntMap.lookup i m
1364 Nothing -> do
1365 mIface <- getExternalModIface nm
1366 case mIface of
1367 Nothing -> pure Nothing
1368 Just ModIface { mi_arg_docs = ArgDocMap amap } ->
1369 pure $ unpackHDS <$> (Map.lookup nm amap >>= IntMap.lookup i)
1370
1371 -- | Returns the module a Name belongs to, if it is isn't local.
1372 getExternalModIface :: Name -> TcM (Maybe ModIface)
1373 getExternalModIface nm = do
1374 isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm
1375 if isLocal
1376 then pure Nothing
1377 else case nameModule_maybe nm of
1378 Nothing -> pure Nothing
1379 Just modNm -> do
1380 hsc_env <- getTopEnv
1381 iface <- liftIO $ hscGetModuleInterface hsc_env modNm
1382 pure (Just iface)
1383
1384 -- | Find the GHC name of the first instance that matches the TH type
1385 lookupThInstName :: TH.Type -> TcM Name
1386 lookupThInstName th_type = do
1387 cls_name <- inst_cls_name th_type
1388 insts <- reifyInstances' cls_name (inst_arg_types th_type)
1389 case insts of -- This expands any type synonyms
1390 Left (_, (inst:_)) -> return $ getName inst
1391 Left (_, []) -> noMatches
1392 Right (_, (inst:_)) -> return $ getName inst
1393 Right (_, []) -> noMatches
1394 where
1395 noMatches = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
1396 text "Couldn't find any instances of"
1397 <+> ppr_th th_type
1398 <+> text "to add documentation to"
1399
1400 -- | Get the name of the class for the instance we are documenting
1401 -- > inst_cls_name (Monad Maybe) == Monad
1402 -- > inst_cls_name C = C
1403 inst_cls_name :: TH.Type -> TcM TH.Name
1404 inst_cls_name (TH.AppT t _) = inst_cls_name t
1405 inst_cls_name (TH.SigT n _) = inst_cls_name n
1406 inst_cls_name (TH.VarT n) = pure n
1407 inst_cls_name (TH.ConT n) = pure n
1408 inst_cls_name (TH.PromotedT n) = pure n
1409 inst_cls_name (TH.InfixT _ n _) = pure n
1410 inst_cls_name (TH.UInfixT _ n _) = pure n
1411 inst_cls_name (TH.ParensT t) = inst_cls_name t
1412
1413 inst_cls_name (TH.ForallT _ _ _) = inst_cls_name_err
1414 inst_cls_name (TH.ForallVisT _ _) = inst_cls_name_err
1415 inst_cls_name (TH.AppKindT _ _) = inst_cls_name_err
1416 inst_cls_name (TH.TupleT _) = inst_cls_name_err
1417 inst_cls_name (TH.UnboxedTupleT _) = inst_cls_name_err
1418 inst_cls_name (TH.UnboxedSumT _) = inst_cls_name_err
1419 inst_cls_name TH.ArrowT = inst_cls_name_err
1420 inst_cls_name TH.MulArrowT = inst_cls_name_err
1421 inst_cls_name TH.EqualityT = inst_cls_name_err
1422 inst_cls_name TH.ListT = inst_cls_name_err
1423 inst_cls_name (TH.PromotedTupleT _) = inst_cls_name_err
1424 inst_cls_name TH.PromotedNilT = inst_cls_name_err
1425 inst_cls_name TH.PromotedConsT = inst_cls_name_err
1426 inst_cls_name TH.StarT = inst_cls_name_err
1427 inst_cls_name TH.ConstraintT = inst_cls_name_err
1428 inst_cls_name (TH.LitT _) = inst_cls_name_err
1429 inst_cls_name TH.WildCardT = inst_cls_name_err
1430 inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err
1431
1432 inst_cls_name_err = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
1433 text "Couldn't work out what instance"
1434 <+> ppr_th th_type
1435 <+> text "is supposed to be"
1436
1437 -- | Basically does the opposite of 'mkThAppTs'
1438 -- > inst_arg_types (Monad Maybe) == [Maybe]
1439 -- > inst_arg_types C == []
1440 inst_arg_types :: TH.Type -> [TH.Type]
1441 inst_arg_types (TH.AppT _ args) =
1442 let go (TH.AppT t ts) = t:go ts
1443 go t = [t]
1444 in go args
1445 inst_arg_types _ = []
1446
1447 -- | Adds a mod finalizer reference to the local environment.
1448 addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
1449 addModFinalizerRef finRef = do
1450 th_stage <- getStage
1451 case th_stage of
1452 RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)
1453 -- This case happens only if a splice is executed and the caller does
1454 -- not set the 'ThStage' to 'RunSplice' to collect finalizers.
1455 -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
1456 _ ->
1457 pprPanic "addModFinalizer was called when no finalizers were collected"
1458 (ppr th_stage)
1459
1460 -- | Releases the external interpreter state.
1461 finishTH :: TcM ()
1462 finishTH = do
1463 hsc_env <- getTopEnv
1464 case interpInstance <$> hsc_interp hsc_env of
1465 Nothing -> pure ()
1466 #if defined(HAVE_INTERNAL_INTERPRETER)
1467 Just InternalInterp -> pure ()
1468 #endif
1469 Just (ExternalInterp {}) -> do
1470 tcg <- getGblEnv
1471 writeTcRef (tcg_th_remote_state tcg) Nothing
1472
1473
1474 runTHExp :: ForeignHValue -> TcM TH.Exp
1475 runTHExp = runTH THExp
1476
1477 runTHPat :: ForeignHValue -> TcM TH.Pat
1478 runTHPat = runTH THPat
1479
1480 runTHType :: ForeignHValue -> TcM TH.Type
1481 runTHType = runTH THType
1482
1483 runTHDec :: ForeignHValue -> TcM [TH.Dec]
1484 runTHDec = runTH THDec
1485
1486 runTH :: Binary a => THResultType -> ForeignHValue -> TcM a
1487 runTH ty fhv = do
1488 interp <- tcGetInterp
1489 case interpInstance interp of
1490 #if defined(HAVE_INTERNAL_INTERPRETER)
1491 InternalInterp -> do
1492 -- Run it in the local TcM
1493 hv <- liftIO $ wormhole interp fhv
1494 r <- runQuasi (unsafeCoerce hv :: TH.Q a)
1495 return r
1496 #endif
1497
1498 ExternalInterp conf iserv ->
1499 -- Run it on the server. For an overview of how TH works with
1500 -- Remote GHCi, see Note [Remote Template Haskell] in
1501 -- libraries/ghci/GHCi/TH.hs.
1502 withIServ_ conf iserv $ \i -> do
1503 rstate <- getTHState i
1504 loc <- TH.qLocation
1505 liftIO $
1506 withForeignRef rstate $ \state_hv ->
1507 withForeignRef fhv $ \q_hv ->
1508 writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))
1509 runRemoteTH i []
1510 bs <- readQResult i
1511 return $! runGet get (LB.fromStrict bs)
1512
1513
1514 -- | communicate with a remotely-running TH computation until it finishes.
1515 -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
1516 runRemoteTH
1517 :: IServInstance
1518 -> [Messages TcRnMessage] -- saved from nested calls to qRecover
1519 -> TcM ()
1520 runRemoteTH iserv recovers = do
1521 THMsg msg <- liftIO $ readIServ iserv getTHMessage
1522 case msg of
1523 RunTHDone -> return ()
1524 StartRecover -> do -- Note [TH recover with -fexternal-interpreter]
1525 v <- getErrsVar
1526 msgs <- readTcRef v
1527 writeTcRef v emptyMessages
1528 runRemoteTH iserv (msgs : recovers)
1529 EndRecover caught_error -> do
1530 let (prev_msgs, rest) = case recovers of
1531 [] -> panic "EndRecover"
1532 a : b -> (a,b)
1533 v <- getErrsVar
1534 warn_msgs <- getWarningMessages <$> readTcRef v
1535 -- keep the warnings only if there were no errors
1536 writeTcRef v $ if caught_error
1537 then prev_msgs
1538 else mkMessages warn_msgs `unionMessages` prev_msgs
1539 runRemoteTH iserv rest
1540 _other -> do
1541 r <- handleTHMessage msg
1542 liftIO $ writeIServ iserv (put r)
1543 runRemoteTH iserv recovers
1544
1545 -- | Read a value of type QResult from the iserv
1546 readQResult :: Binary a => IServInstance -> TcM a
1547 readQResult i = do
1548 qr <- liftIO $ readIServ i get
1549 case qr of
1550 QDone a -> return a
1551 QException str -> liftIO $ throwIO (ErrorCall str)
1552 QFail str -> fail str
1553
1554 {- Note [TH recover with -fexternal-interpreter]
1555
1556 Recover is slightly tricky to implement.
1557
1558 The meaning of "recover a b" is
1559 - Do a
1560 - If it finished with no errors, then keep the warnings it generated
1561 - If it failed, discard any messages it generated, and do b
1562
1563 Note that "failed" here can mean either
1564 (1) threw an exception (failTc)
1565 (2) generated an error message (addErrTcM)
1566
1567 The messages are managed by GHC in the TcM monad, whereas the
1568 exception-handling is done in the ghc-iserv process, so we have to
1569 coordinate between the two.
1570
1571 On the server:
1572 - emit a StartRecover message
1573 - run "a; FailIfErrs" inside a try
1574 - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed
1575 - if "a; FailIfErrs" failed, run "b"
1576
1577 Back in GHC, when we receive:
1578
1579 FailIfErrrs
1580 failTc if there are any error messages (= failIfErrsM)
1581 StartRecover
1582 save the current messages and start with an empty set.
1583 EndRecover caught_error
1584 Restore the previous messages,
1585 and merge in the new messages if caught_error is false.
1586 -}
1587
1588 -- | Retrieve (or create, if it hasn't been created already), the
1589 -- remote TH state. The TH state is a remote reference to an IORef
1590 -- QState living on the server, and we have to pass this to each RunTH
1591 -- call we make.
1592 --
1593 -- The TH state is stored in tcg_th_remote_state in the TcGblEnv.
1594 --
1595 getTHState :: IServInstance -> TcM (ForeignRef (IORef QState))
1596 getTHState i = do
1597 tcg <- getGblEnv
1598 th_state <- readTcRef (tcg_th_remote_state tcg)
1599 case th_state of
1600 Just rhv -> return rhv
1601 Nothing -> do
1602 interp <- tcGetInterp
1603 fhv <- liftIO $ mkFinalizedHValue interp =<< iservCall i StartTH
1604 writeTcRef (tcg_th_remote_state tcg) (Just fhv)
1605 return fhv
1606
1607 wrapTHResult :: TcM a -> TcM (THResult a)
1608 wrapTHResult tcm = do
1609 e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic
1610 case e of
1611 Left e -> return (THException (show e))
1612 Right a -> return (THComplete a)
1613
1614 handleTHMessage :: THMessage a -> TcM a
1615 handleTHMessage msg = case msg of
1616 NewName a -> wrapTHResult $ TH.qNewName a
1617 Report b str -> wrapTHResult $ TH.qReport b str
1618 LookupName b str -> wrapTHResult $ TH.qLookupName b str
1619 Reify n -> wrapTHResult $ TH.qReify n
1620 ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
1621 ReifyType n -> wrapTHResult $ TH.qReifyType n
1622 ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
1623 ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
1624 ReifyAnnotations lookup tyrep ->
1625 wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
1626 ReifyModule m -> wrapTHResult $ TH.qReifyModule m
1627 ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
1628 AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
1629 AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
1630 AddModFinalizer r -> do
1631 interp <- hscInterp <$> getTopEnv
1632 wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef
1633 AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
1634 AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
1635 AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
1636 IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
1637 ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
1638 PutDoc l s -> wrapTHResult $ TH.qPutDoc l s
1639 GetDoc l -> wrapTHResult $ TH.qGetDoc l
1640 FailIfErrs -> wrapTHResult failIfErrsM
1641 _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
1642
1643 getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
1644 getAnnotationsByTypeRep th_name tyrep
1645 = do { name <- lookupThAnnLookup th_name
1646 ; topEnv <- getTopEnv
1647 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1648 ; tcg <- getGblEnv
1649 ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep
1650 ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep
1651 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1652
1653 {-
1654 ************************************************************************
1655 * *
1656 Instance Testing
1657 * *
1658 ************************************************************************
1659 -}
1660
1661 reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
1662 reifyInstances th_nm th_tys
1663 = do { insts <- reifyInstances' th_nm th_tys
1664 ; case insts of
1665 Left (cls, cls_insts) ->
1666 reifyClassInstances cls cls_insts
1667 Right (tc, fam_insts) ->
1668 reifyFamilyInstances tc fam_insts }
1669
1670 reifyInstances' :: TH.Name
1671 -> [TH.Type]
1672 -> TcM (Either (Class, [ClsInst]) (TyCon, [FamInst]))
1673 -- ^ Returns 'Left' in the case that the instances were found to
1674 -- be class instances, or 'Right' if they are family instances.
1675 reifyInstances' th_nm th_tys
1676 = addErrCtxt (text "In the argument of reifyInstances:"
1677 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
1678 do { loc <- getSrcSpanM
1679 ; th_origin <- getThSpliceOrigin
1680 ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys)
1681 -- #9262 says to bring vars into scope, like in HsForAllTy case
1682 -- of rnHsTyKi
1683 ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty
1684 -- Rename to HsType Name
1685 ; ((tv_names, rn_ty), _fvs)
1686 <- checkNoErrs $ -- If there are out-of-scope Names here, then we
1687 -- must error before proceeding to typecheck the
1688 -- renamed type, as that will result in GHC
1689 -- internal errors (#13837).
1690 rnImplicitTvOccs Nothing tv_rdrs $ \ tv_names ->
1691 do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
1692 ; return ((tv_names, rn_ty), fvs) }
1693
1694 ; (tclvl, wanted, (tvs, ty))
1695 <- pushLevelAndSolveEqualitiesX "reifyInstances" $
1696 bindImplicitTKBndrs_Skol tv_names $
1697 tcInferLHsType rn_ty
1698
1699 ; tvs <- zonkAndScopedSort tvs
1700
1701 -- Avoid error cascade if there are unsolved
1702 ; reportUnsolvedEqualities ReifySkol tvs tclvl wanted
1703
1704 ; ty <- zonkTcTypeToType ty
1705 -- Substitute out the meta type variables
1706 -- In particular, the type might have kind
1707 -- variables inside it (#7477)
1708
1709 ; traceTc "reifyInstances'" (ppr ty $$ ppr (tcTypeKind ty))
1710 ; case splitTyConApp_maybe ty of -- This expands any type synonyms
1711 Just (tc, tys) -- See #7910
1712 | Just cls <- tyConClass_maybe tc
1713 -> do { inst_envs <- tcGetInstEnvs
1714 ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys
1715 ; traceTc "reifyInstances'1" (ppr matches)
1716 ; return $ Left (cls, map fst matches ++ unifies) }
1717 | isOpenFamilyTyCon tc
1718 -> do { inst_envs <- tcGetFamInstEnvs
1719 ; let matches = lookupFamInstEnv inst_envs tc tys
1720 ; traceTc "reifyInstances'2" (ppr matches)
1721 ; return $ Right (tc, map fim_instance matches) }
1722 _ -> bale_out $ TcRnUnknownMessage $ mkPlainError noHints $
1723 (hang (text "reifyInstances:" <+> quotes (ppr ty))
1724 2 (text "is not a class constraint or type family application")) }
1725 where
1726 doc = ClassInstanceCtx
1727 bale_out msg = failWithTc msg
1728
1729 cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)
1730 cvt origin loc th_ty = case convertToHsType origin loc th_ty of
1731 Left msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)
1732 Right ty -> return ty
1733
1734 {-
1735 ************************************************************************
1736 * *
1737 Reification
1738 * *
1739 ************************************************************************
1740 -}
1741
1742 lookupName :: Bool -- True <=> type namespace
1743 -- False <=> value namespace
1744 -> String -> TcM (Maybe TH.Name)
1745 lookupName is_type_name s
1746 = do { mb_nm <- lookupOccRn_maybe rdr_name
1747 ; return (fmap reifyName mb_nm) }
1748 where
1749 th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M'
1750
1751 occ_fs :: FastString
1752 occ_fs = mkFastString (TH.nameBase th_name)
1753
1754 occ :: OccName
1755 occ | is_type_name
1756 = if isLexVarSym occ_fs || isLexCon occ_fs
1757 then mkTcOccFS occ_fs
1758 else mkTyVarOccFS occ_fs
1759 | otherwise
1760 = if isLexCon occ_fs then mkDataOccFS occ_fs
1761 else mkVarOccFS occ_fs
1762
1763 rdr_name = case TH.nameModule th_name of
1764 Nothing -> mkRdrUnqual occ
1765 Just mod -> mkRdrQual (mkModuleName mod) occ
1766
1767 getThing :: TH.Name -> TcM TcTyThing
1768 getThing th_name
1769 = do { name <- lookupThName th_name
1770 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
1771 ; tcLookupTh name }
1772 -- ToDo: this tcLookup could fail, which would give a
1773 -- rather unhelpful error message
1774 where
1775 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
1776 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
1777 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
1778 ppr_ns _ = panic "reify/ppr_ns"
1779
1780 reify :: TH.Name -> TcM TH.Info
1781 reify th_name
1782 = do { traceTc "reify 1" (text (TH.showName th_name))
1783 ; thing <- getThing th_name
1784 ; traceTc "reify 2" (ppr thing)
1785 ; reifyThing thing }
1786
1787 lookupThName :: TH.Name -> TcM Name
1788 lookupThName th_name = do
1789 mb_name <- lookupThName_maybe th_name
1790 case mb_name of
1791 Nothing -> failWithTc (notInScope th_name)
1792 Just name -> return name
1793
1794 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
1795 lookupThName_maybe th_name
1796 = do { names <- mapMaybeM lookupOccRn_maybe (thRdrNameGuesses th_name)
1797 -- Pick the first that works
1798 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
1799 ; return (listToMaybe names) }
1800
1801 tcLookupTh :: Name -> TcM TcTyThing
1802 -- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that
1803 -- it gives a reify-related error message on failure, whereas in the normal
1804 -- tcLookup, failure is a bug.
1805 tcLookupTh name
1806 = do { (gbl_env, lcl_env) <- getEnvs
1807 ; case lookupNameEnv (tcl_env lcl_env) name of {
1808 Just thing -> return thing;
1809 Nothing ->
1810
1811 case lookupNameEnv (tcg_type_env gbl_env) name of {
1812 Just thing -> return (AGlobal thing);
1813 Nothing ->
1814
1815 -- EZY: I don't think this choice matters, no TH in signatures!
1816 if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name
1817 then -- It's defined in this module
1818 failWithTc (notInEnv name)
1819
1820 else
1821 do { mb_thing <- tcLookupImported_maybe name
1822 ; case mb_thing of
1823 Succeeded thing -> return (AGlobal thing)
1824 Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)
1825 }}}}
1826
1827 notInScope :: TH.Name -> TcRnMessage
1828 notInScope th_name = TcRnUnknownMessage $ mkPlainError noHints $
1829 quotes (text (TH.pprint th_name)) <+>
1830 text "is not in scope at a reify"
1831 -- Ugh! Rather an indirect way to display the name
1832
1833 notInEnv :: Name -> TcRnMessage
1834 notInEnv name = TcRnUnknownMessage $ mkPlainError noHints $
1835 quotes (ppr name) <+> text "is not in the type environment at a reify"
1836
1837 ------------------------------
1838 reifyRoles :: TH.Name -> TcM [TH.Role]
1839 reifyRoles th_name
1840 = do { thing <- getThing th_name
1841 ; case thing of
1842 AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
1843 _ -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing))
1844 }
1845 where
1846 reify_role Nominal = TH.NominalR
1847 reify_role Representational = TH.RepresentationalR
1848 reify_role Phantom = TH.PhantomR
1849
1850 ------------------------------
1851 reifyThing :: TcTyThing -> TcM TH.Info
1852 -- The only reason this is monadic is for error reporting,
1853 -- which in turn is mainly for the case when TH can't express
1854 -- some random GHC extension
1855
1856 reifyThing (AGlobal (AnId id))
1857 = do { ty <- reifyType (idType id)
1858 ; let v = reifyName id
1859 ; case idDetails id of
1860 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))
1861 RecSelId{sel_tycon=RecSelData tc}
1862 -> return (TH.VarI (reifySelector id tc) ty Nothing)
1863 _ -> return (TH.VarI v ty Nothing)
1864 }
1865
1866 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
1867 reifyThing (AGlobal (AConLike (RealDataCon dc)))
1868 = do { let name = dataConName dc
1869 ; ty <- reifyType (idType (dataConWrapId dc))
1870 ; return (TH.DataConI (reifyName name) ty
1871 (reifyName (dataConOrigTyCon dc)))
1872 }
1873
1874 reifyThing (AGlobal (AConLike (PatSynCon ps)))
1875 = do { let name = reifyName ps
1876 ; ty <- reifyPatSynType (patSynSigBndr ps)
1877 ; return (TH.PatSynI name ty) }
1878
1879 reifyThing (ATcId {tct_id = id})
1880 = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
1881 -- though it may be incomplete
1882 ; ty2 <- reifyType ty1
1883 ; return (TH.VarI (reifyName id) ty2 Nothing) }
1884
1885 reifyThing (ATyVar tv tv1)
1886 = do { ty1 <- zonkTcTyVar tv1
1887 ; ty2 <- reifyType ty1
1888 ; return (TH.TyVarI (reifyName tv) ty2) }
1889
1890 reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
1891
1892 -------------------------------------------
1893 reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
1894 reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
1895 , cab_lhs = lhs
1896 , cab_rhs = rhs })
1897 -- remove kind patterns (#8884)
1898 = do { tvs' <- reifyTyVarsToMaybe tvs
1899 ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
1900 ; lhs' <- reifyTypes lhs_types_only
1901 ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc)
1902 lhs_types_only lhs'
1903 ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs
1904 ; rhs' <- reifyType rhs
1905 ; return (TH.TySynEqn tvs' lhs_type rhs') }
1906
1907 reifyTyCon :: TyCon -> TcM TH.Info
1908 reifyTyCon tc
1909 | Just cls <- tyConClass_maybe tc
1910 = reifyClass cls
1911
1912 | isFunTyCon tc
1913 = return (TH.PrimTyConI (reifyName tc) 2 False)
1914
1915 | isPrimTyCon tc
1916 = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc))
1917 (isUnliftedTyCon tc))
1918
1919 | isTypeFamilyTyCon tc
1920 = do { let tvs = tyConTyVars tc
1921 res_kind = tyConResKind tc
1922 resVar = famTcResVar tc
1923
1924 ; kind' <- reifyKind res_kind
1925 ; let (resultSig, injectivity) =
1926 case resVar of
1927 Nothing -> (TH.KindSig kind', Nothing)
1928 Just name ->
1929 let thName = reifyName name
1930 injAnnot = tyConInjectivityInfo tc
1931 sig = TH.TyVarSig (TH.KindedTV thName () kind')
1932 inj = case injAnnot of
1933 NotInjective -> Nothing
1934 Injective ms ->
1935 Just (TH.InjectivityAnn thName injRHS)
1936 where
1937 injRHS = map (reifyName . tyVarName)
1938 (filterByList ms tvs)
1939 in (sig, inj)
1940 ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
1941 ; let tfHead =
1942 TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity
1943 ; if isOpenTypeFamilyTyCon tc
1944 then do { fam_envs <- tcGetFamInstEnvs
1945 ; instances <- reifyFamilyInstances tc
1946 (familyInstances fam_envs tc)
1947 ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) }
1948 else do { eqns <-
1949 case isClosedSynFamilyTyConWithAxiom_maybe tc of
1950 Just ax -> mapM (reifyAxBranch tc) $
1951 fromBranches $ coAxiomBranches ax
1952 Nothing -> return []
1953 ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns)
1954 []) } }
1955
1956 | isDataFamilyTyCon tc
1957 = do { let res_kind = tyConResKind tc
1958
1959 ; kind' <- fmap Just (reifyKind res_kind)
1960
1961 ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
1962 ; fam_envs <- tcGetFamInstEnvs
1963 ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)
1964 ; return (TH.FamilyI
1965 (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }
1966
1967 | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym
1968 = do { rhs' <- reifyType rhs
1969 ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
1970 ; return (TH.TyConI
1971 (TH.TySynD (reifyName tc) tvs' rhs'))
1972 }
1973
1974 | otherwise
1975 = do { cxt <- reifyCxt (tyConStupidTheta tc)
1976 ; let tvs = tyConTyVars tc
1977 dataCons = tyConDataCons tc
1978 isGadt = isGadtSyntaxTyCon tc
1979 ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
1980 ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc)
1981 ; let name = reifyName tc
1982 deriv = [] -- Don't know about deriving
1983 decl | isNewTyCon tc =
1984 TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv
1985 | otherwise =
1986 TH.DataD cxt name r_tvs Nothing cons deriv
1987 ; return (TH.TyConI decl) }
1988
1989 reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con
1990 reifyDataCon isGadtDataCon tys dc
1991 = do { let -- used for H98 data constructors
1992 (ex_tvs, theta, arg_tys)
1993 = dataConInstSig dc tys
1994 -- used for GADTs data constructors
1995 g_user_tvs' = dataConUserTyVarBinders dc
1996 (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty')
1997 = dataConFullSig dc
1998 (srcUnpks, srcStricts)
1999 = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
2000 dcdBangs = zipWith TH.Bang srcUnpks srcStricts
2001 fields = dataConFieldLabels dc
2002 name = reifyName dc
2003 -- Universal tvs present in eq_spec need to be filtered out, as
2004 -- they will not appear anywhere in the type.
2005 eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec)
2006
2007 ; (univ_subst, _)
2008 -- See Note [Freshen reified GADT constructors' universal tyvars]
2009 <- freshenTyVarBndrs $
2010 filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs
2011 ; let (tvb_subst, g_user_tvs) = subst_tv_binders univ_subst g_user_tvs'
2012 g_theta = substTys tvb_subst g_theta'
2013 g_arg_tys = substTys tvb_subst (map scaledThing g_arg_tys')
2014 g_res_ty = substTy tvb_subst g_res_ty'
2015
2016 ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
2017
2018 ; main_con <-
2019 if | not (null fields) && not isGadtDataCon ->
2020 return $ TH.RecC name (zip3 (map reifyFieldLabel fields)
2021 dcdBangs r_arg_tys)
2022 | not (null fields) -> do
2023 { res_ty <- reifyType g_res_ty
2024 ; return $ TH.RecGadtC [name]
2025 (zip3 (map (reifyName . flSelector) fields)
2026 dcdBangs r_arg_tys) res_ty }
2027 -- We need to check not isGadtDataCon here because GADT
2028 -- constructors can be declared infix.
2029 -- See Note [Infix GADT constructors] in GHC.Tc.TyCl.
2030 | dataConIsInfix dc && not isGadtDataCon ->
2031 assert (r_arg_tys `lengthIs` 2) $ do
2032 { let [r_a1, r_a2] = r_arg_tys
2033 [s1, s2] = dcdBangs
2034 ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
2035 | isGadtDataCon -> do
2036 { res_ty <- reifyType g_res_ty
2037 ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }
2038 | otherwise ->
2039 return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
2040
2041 ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)
2042 | otherwise = assert (all isTyVar ex_tvs)
2043 -- no covars for haskell syntax
2044 (map mk_specified ex_tvs, theta)
2045 ret_con | null ex_tvs' && null theta' = return main_con
2046 | otherwise = do
2047 { cxt <- reifyCxt theta'
2048 ; ex_tvs'' <- reifyTyVarBndrs ex_tvs'
2049 ; return (TH.ForallC ex_tvs'' cxt main_con) }
2050 ; assert (r_arg_tys `equalLength` dcdBangs)
2051 ret_con }
2052 where
2053 mk_specified tv = Bndr tv SpecifiedSpec
2054
2055 subst_tv_binders subst tv_bndrs =
2056 let tvs = binderVars tv_bndrs
2057 flags = map binderArgFlag tv_bndrs
2058 (subst', tvs') = substTyVarBndrs subst tvs
2059 tv_bndrs' = map (\(tv,fl) -> Bndr tv fl) (zip tvs' flags)
2060 in (subst', tv_bndrs')
2061
2062 {-
2063 Note [Freshen reified GADT constructors' universal tyvars]
2064 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2065 Suppose one were to reify this GADT:
2066
2067 data a :~: b where
2068 Refl :: forall a b. (a ~ b) => a :~: b
2069
2070 We ought to be careful here about the uniques we give to the occurrences of `a`
2071 and `b` in this definition. That is because in the original DataCon, all uses
2072 of `a` and `b` have the same unique, since `a` and `b` are both universally
2073 quantified type variables--that is, they are used in both the (:~:) tycon as
2074 well as in the constructor type signature. But when we turn the DataCon
2075 definition into the reified one, the `a` and `b` in the constructor type
2076 signature becomes differently scoped than the `a` and `b` in `data a :~: b`.
2077
2078 While it wouldn't technically be *wrong* per se to re-use the same uniques for
2079 `a` and `b` across these two different scopes, it's somewhat annoying for end
2080 users of Template Haskell, since they wouldn't be able to rely on the
2081 assumption that all TH names have globally distinct uniques (#13885). For this
2082 reason, we freshen the universally quantified tyvars that go into the reified
2083 GADT constructor type signature to give them distinct uniques from their
2084 counterparts in the tycon.
2085 -}
2086
2087 ------------------------------
2088 reifyClass :: Class -> TcM TH.Info
2089 reifyClass cls
2090 = do { cxt <- reifyCxt theta
2091 ; inst_envs <- tcGetInstEnvs
2092 ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
2093 ; assocTys <- concatMapM reifyAT ats
2094 ; ops <- concatMapM reify_op op_stuff
2095 ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls))
2096 ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
2097 ; return (TH.ClassI dec insts) }
2098 where
2099 (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
2100 fds' = map reifyFunDep fds
2101 reify_op (op, def_meth)
2102 = do { let (_, _, ty) = tcSplitMethodTy (idType op)
2103 -- Use tcSplitMethodTy to get rid of the extraneous class
2104 -- variables and predicates at the beginning of op's type
2105 -- (see #15551).
2106 ; ty' <- reifyType ty
2107 ; let nm' = reifyName op
2108 ; case def_meth of
2109 Just (_, GenericDM gdm_ty) ->
2110 do { gdm_ty' <- reifyType gdm_ty
2111 ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] }
2112 _ -> return [TH.SigD nm' ty'] }
2113
2114 reifyAT :: ClassATItem -> TcM [TH.Dec]
2115 reifyAT (ATI tycon def) = do
2116 tycon' <- reifyTyCon tycon
2117 case tycon' of
2118 TH.FamilyI dec _ -> do
2119 let (tyName, tyArgs) = tfNames dec
2120 (dec :) <$> maybe (return [])
2121 (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
2122 def
2123 _ -> pprPanic "reifyAT" (text (show tycon'))
2124
2125 reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
2126 reifyDefImpl n args ty =
2127 TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args))
2128 <$> reifyType ty
2129
2130 tfNames :: TH.Dec -> (TH.Name, [TH.Name])
2131 tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
2132 = (n, map bndrName args)
2133 tfNames d = pprPanic "tfNames" (text (show d))
2134
2135 bndrName :: TH.TyVarBndr flag -> TH.Name
2136 bndrName (TH.PlainTV n _) = n
2137 bndrName (TH.KindedTV n _ _) = n
2138
2139 ------------------------------
2140 -- | Annotate (with TH.SigT) a type if the first parameter is True
2141 -- and if the type contains a free variable.
2142 -- This is used to annotate type patterns for poly-kinded tyvars in
2143 -- reifying class and type instances.
2144 -- See @Note [Reified instances and explicit kind signatures]@.
2145 annotThType :: Bool -- True <=> annotate
2146 -> TyCoRep.Type -> TH.Type -> TcM TH.Type
2147 -- tiny optimization: if the type is annotated, don't annotate again.
2148 annotThType _ _ th_ty@(TH.SigT {}) = return th_ty
2149 annotThType True ty th_ty
2150 | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
2151 = do { let ki = tcTypeKind ty
2152 ; th_ki <- reifyKind ki
2153 ; return (TH.SigT th_ty th_ki) }
2154 annotThType _ _ th_ty = return th_ty
2155
2156 -- | For every argument type that a type constructor accepts,
2157 -- report whether or not the argument is poly-kinded. This is used to
2158 -- eventually feed into 'annotThType'.
2159 -- See @Note [Reified instances and explicit kind signatures]@.
2160 tyConArgsPolyKinded :: TyCon -> [Bool]
2161 tyConArgsPolyKinded tc =
2162 map (is_poly_ty . tyVarKind) tc_vis_tvs
2163 -- See "Wrinkle: Oversaturated data family instances" in
2164 -- @Note [Reified instances and explicit kind signatures]@
2165 ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle
2166 ++ repeat True -- (2) in Wrinkle
2167 where
2168 is_poly_ty :: Type -> Bool
2169 is_poly_ty ty = not $
2170 isEmptyVarSet $
2171 filterVarSet isTyVar $
2172 tyCoVarsOfType ty
2173
2174 tc_vis_tvs :: [TyVar]
2175 tc_vis_tvs = tyConVisibleTyVars tc
2176
2177 tc_res_kind_vis_bndrs :: [TyCoBinder]
2178 tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc
2179
2180 {-
2181 Note [Reified instances and explicit kind signatures]
2182 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2183 Reified class instances and type family instances often include extra kind
2184 information to disambiguate instances. Here is one such example that
2185 illustrates this (#8953):
2186
2187 type family Poly (a :: k) :: Type
2188 type instance Poly (x :: Bool) = Int
2189 type instance Poly (x :: Maybe k) = Double
2190
2191 If you're not careful, reifying these instances might yield this:
2192
2193 type instance Poly x = Int
2194 type instance Poly x = Double
2195
2196 To avoid this, we go through some care to annotate things with extra kind
2197 information. Some functions which accomplish this feat include:
2198
2199 * annotThType: This annotates a type with a kind signature if the type contains
2200 a free variable.
2201 * tyConArgsPolyKinded: This checks every argument that a type constructor can
2202 accept and reports if the type of the argument is poly-kinded. This
2203 information is ultimately fed into annotThType.
2204
2205 -----
2206 -- Wrinkle: Oversaturated data family instances
2207 -----
2208
2209 What constitutes an argument to a type constructor in the definition of
2210 tyConArgsPolyKinded? For most type constructors, it's simply the visible
2211 type variable binders (i.e., tyConVisibleTyVars). There is one corner case
2212 we must keep in mind, however: data family instances can appear oversaturated
2213 (#17296). For instance:
2214
2215 data family Foo :: Type -> Type
2216 data instance Foo x
2217
2218 data family Bar :: k
2219 data family Bar x
2220
2221 For these sorts of data family instances, tyConVisibleTyVars isn't enough,
2222 as they won't give you the kinds of the oversaturated arguments. We must
2223 also consult:
2224
2225 1. The kinds of the arguments in the result kind (i.e., the tyConResKind).
2226 This will tell us, e.g., the kind of `x` in `Foo x` above.
2227 2. If we go beyond the number of arguments in the result kind (like the
2228 `x` in `Bar x`), then we conservatively assume that the argument's
2229 kind is poly-kinded.
2230
2231 -----
2232 -- Wrinkle: data family instances with return kinds
2233 -----
2234
2235 Another squirrelly corner case is this:
2236
2237 data family Foo (a :: k)
2238 data instance Foo :: Bool -> Type
2239 data instance Foo :: Char -> Type
2240
2241 If you're not careful, reifying these instances might yield this:
2242
2243 data instance Foo
2244 data instance Foo
2245
2246 We can fix this ambiguity by reifying the instances' explicit return kinds. We
2247 should only do this if necessary (see
2248 Note [When does a tycon application need an explicit kind signature?] in GHC.Core.Type),
2249 but more importantly, we *only* do this if either of the following are true:
2250
2251 1. The data family instance has no constructors.
2252 2. The data family instance is declared with GADT syntax.
2253
2254 If neither of these are true, then reifying the return kind would yield
2255 something like this:
2256
2257 data instance (Bar a :: Type) = MkBar a
2258
2259 Which is not valid syntax.
2260 -}
2261
2262 ------------------------------
2263 reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
2264 reifyClassInstances cls insts
2265 = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts
2266
2267 reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
2268 -- includes only *visible* tvs
2269 -> ClsInst -> TcM TH.Dec
2270 reifyClassInstance is_poly_tvs i
2271 = do { cxt <- reifyCxt theta
2272 ; let vis_types = filterOutInvisibleTypes cls_tc types
2273 ; thtypes <- reifyTypes vis_types
2274 ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
2275 ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
2276 ; return $ (TH.InstanceD over cxt head_ty []) }
2277 where
2278 (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
2279 cls_tc = classTyCon cls
2280 dfun = instanceDFunId i
2281 over = case overlapMode (is_flag i) of
2282 NoOverlap _ -> Nothing
2283 Overlappable _ -> Just TH.Overlappable
2284 Overlapping _ -> Just TH.Overlapping
2285 Overlaps _ -> Just TH.Overlaps
2286 Incoherent _ -> Just TH.Incoherent
2287
2288 ------------------------------
2289 reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
2290 reifyFamilyInstances fam_tc fam_insts
2291 = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts
2292
2293 reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
2294 -- includes only *visible* tvs
2295 -> FamInst -> TcM TH.Dec
2296 reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor
2297 , fi_axiom = ax
2298 , fi_fam = fam })
2299 | let fam_tc = coAxiomTyCon ax
2300 branch = coAxiomSingleBranch ax
2301 , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch
2302 = case flavor of
2303 SynFamilyInst ->
2304 -- remove kind patterns (#8884)
2305 do { th_tvs <- reifyTyVarsToMaybe tvs
2306 ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
2307 ; th_lhs <- reifyTypes lhs_types_only
2308 ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
2309 th_lhs
2310 ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs
2311 ; th_rhs <- reifyType rhs
2312 ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) }
2313
2314 DataFamilyInst rep_tc ->
2315 do { let -- eta-expand lhs types, because sometimes data/newtype
2316 -- instances are eta-reduced; See #9692
2317 -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
2318 (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch
2319 fam' = reifyName fam
2320 dataCons = tyConDataCons rep_tc
2321 isGadt = isGadtSyntaxTyCon rep_tc
2322 ; th_tvs <- reifyTyVarsToMaybe ee_tvs
2323 ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons
2324 ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs
2325 ; th_tys <- reifyTypes types_only
2326 ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
2327 ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys
2328 ; mb_sig <-
2329 -- See "Wrinkle: data family instances with return kinds" in
2330 -- Note [Reified instances and explicit kind signatures]
2331 if (null cons || isGadtSyntaxTyCon rep_tc)
2332 && tyConAppNeedsKindSig False fam_tc (length ee_lhs)
2333 then do { let full_kind = tcTypeKind (mkTyConApp fam_tc ee_lhs)
2334 ; th_full_kind <- reifyKind full_kind
2335 ; pure $ Just th_full_kind }
2336 else pure Nothing
2337 ; return $
2338 if isNewTyCon rep_tc
2339 then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) []
2340 else TH.DataInstD [] th_tvs lhs_type mb_sig cons []
2341 }
2342
2343 ------------------------------
2344 reifyType :: TyCoRep.Type -> TcM TH.Type
2345 -- Monadic only because of failure
2346 reifyType ty | tcIsLiftedTypeKind ty = return TH.StarT
2347 -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it
2348 -- with Constraint (#14869).
2349 reifyType ty@(ForAllTy (Bndr _ argf) _)
2350 = reify_for_all argf ty
2351 reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) }
2352 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
2353 reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
2354 reifyType ty@(AppTy {}) = do
2355 let (ty_head, ty_args) = splitAppTys ty
2356 ty_head' <- reifyType ty_head
2357 ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args)
2358 pure $ mkThAppTs ty_head' ty_args'
2359 where
2360 -- Make sure to filter out any invisible arguments. For instance, if you
2361 -- reify the following:
2362 --
2363 -- newtype T (f :: forall a. a -> Type) = MkT (f Bool)
2364 --
2365 -- Then you should receive back `f Bool`, not `f Type Bool`, since the
2366 -- `Type` argument is invisible (#15792).
2367 filter_out_invisible_args :: Type -> [Type] -> [Type]
2368 filter_out_invisible_args ty_head ty_args =
2369 filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)
2370 ty_args
2371 reifyType ty@(FunTy { ft_af = af, ft_mult = Many, ft_arg = t1, ft_res = t2 })
2372 | InvisArg <- af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char)
2373 | otherwise = do { [r1,r2] <- reifyTypes [t1,t2]
2374 ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
2375 reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 })
2376 | InvisArg <- af = noTH (text "linear invisible argument") (ppr ty)
2377 | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2]
2378 ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) }
2379 reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH
2380 reifyType ty@(CoercionTy {})= noTH (text "coercions in types") (ppr ty)
2381
2382 reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type
2383 -- Arg of reify_for_all is always ForAllTy or a predicate FunTy
2384 reify_for_all argf ty
2385 | isVisibleArgFlag argf
2386 = do let (req_bndrs, phi) = tcSplitForAllReqTVBinders ty
2387 tvbndrs' <- reifyTyVarBndrs req_bndrs
2388 phi' <- reifyType phi
2389 pure $ TH.ForallVisT tvbndrs' phi'
2390 | otherwise
2391 = do let (inv_bndrs, phi) = tcSplitForAllInvisTVBinders ty
2392 tvbndrs' <- reifyTyVarBndrs inv_bndrs
2393 let (cxt, tau) = tcSplitPhiTy phi
2394 cxt' <- reifyCxt cxt
2395 tau' <- reifyType tau
2396 pure $ TH.ForallT tvbndrs' cxt' tau'
2397
2398 reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
2399 reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
2400 reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
2401 reifyTyLit (CharTyLit c) = return (TH.CharTyLit c)
2402
2403 reifyTypes :: [Type] -> TcM [TH.Type]
2404 reifyTypes = mapM reifyType
2405
2406 reifyPatSynType
2407 :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type) -> TcM TH.Type
2408 -- reifies a pattern synonym's type and returns its *complete* type
2409 -- signature; see NOTE [Pattern synonym signatures and Template
2410 -- Haskell]
2411 reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
2412 = do { univTyVars' <- reifyTyVarBndrs univTyVars
2413 ; req' <- reifyCxt req
2414 ; exTyVars' <- reifyTyVarBndrs exTyVars
2415 ; prov' <- reifyCxt prov
2416 ; tau' <- reifyType (mkVisFunTys argTys resTy)
2417 ; return $ TH.ForallT univTyVars' req'
2418 $ TH.ForallT exTyVars' prov' tau' }
2419
2420 reifyKind :: Kind -> TcM TH.Kind
2421 reifyKind = reifyType
2422
2423 reifyCxt :: [PredType] -> TcM [TH.Pred]
2424 reifyCxt = mapM reifyType
2425
2426 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
2427 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
2428
2429 class ReifyFlag flag flag' | flag -> flag' where
2430 reifyFlag :: flag -> flag'
2431
2432 instance ReifyFlag () () where
2433 reifyFlag () = ()
2434
2435 instance ReifyFlag Specificity TH.Specificity where
2436 reifyFlag SpecifiedSpec = TH.SpecifiedSpec
2437 reifyFlag InferredSpec = TH.InferredSpec
2438
2439 reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr ()]
2440 reifyTyVars = reifyTyVarBndrs . map mk_bndr
2441 where
2442 mk_bndr tv = Bndr tv ()
2443
2444 reifyTyVarBndrs :: ReifyFlag flag flag'
2445 => [VarBndr TyVar flag] -> TcM [TH.TyVarBndr flag']
2446 reifyTyVarBndrs = mapM reify_tvbndr
2447 where
2448 -- even if the kind is *, we need to include a kind annotation,
2449 -- in case a poly-kind would be inferred without the annotation.
2450 -- See #8953 or test th/T8953
2451 reify_tvbndr (Bndr tv fl) = TH.KindedTV (reifyName tv)
2452 (reifyFlag fl)
2453 <$> reifyKind (tyVarKind tv)
2454
2455 reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr ()])
2456 reifyTyVarsToMaybe [] = pure Nothing
2457 reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys
2458
2459 reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
2460 reify_tc_app tc tys
2461 = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
2462 ; maybe_sig_t (mkThAppTs r_tc tys') }
2463 where
2464 arity = tyConArity tc
2465
2466 r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2)
2467 | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2)
2468 | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2)
2469 -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
2470 | isTupleTyCon tc = if isPromotedDataCon tc
2471 then TH.PromotedTupleT arity
2472 else TH.TupleT arity
2473 | tc `hasKey` constraintKindTyConKey
2474 = TH.ConstraintT
2475 | tc `hasKey` unrestrictedFunTyConKey = TH.ArrowT
2476 | tc `hasKey` listTyConKey = TH.ListT
2477 | tc `hasKey` nilDataConKey = TH.PromotedNilT
2478 | tc `hasKey` consDataConKey = TH.PromotedConsT
2479 | tc `hasKey` heqTyConKey = TH.EqualityT
2480 | tc `hasKey` eqPrimTyConKey = TH.EqualityT
2481 | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
2482 | isPromotedDataCon tc = TH.PromotedT (reifyName tc)
2483 | otherwise = TH.ConT (reifyName tc)
2484
2485 -- See Note [When does a tycon application need an explicit kind
2486 -- signature?] in GHC.Core.TyCo.Rep
2487 maybe_sig_t th_type
2488 | tyConAppNeedsKindSig
2489 False -- We don't reify types using visible kind applications, so
2490 -- don't count specified binders as contributing towards
2491 -- injective positions in the kind of the tycon.
2492 tc (length tys)
2493 = do { let full_kind = tcTypeKind (mkTyConApp tc tys)
2494 ; th_full_kind <- reifyKind full_kind
2495 ; return (TH.SigT th_type th_full_kind) }
2496 | otherwise
2497 = return th_type
2498
2499 ------------------------------
2500 reifyName :: NamedThing n => n -> TH.Name
2501 reifyName thing
2502 | isExternalName name
2503 = mk_varg pkg_str mod_str occ_str
2504 | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name))
2505 -- Many of the things we reify have local bindings, and
2506 -- NameL's aren't supposed to appear in binding positions, so
2507 -- we use NameU. When/if we start to reify nested things, that
2508 -- have free variables, we may need to generate NameL's for them.
2509 where
2510 name = getName thing
2511 mod = assert (isExternalName name) $ nameModule name
2512 pkg_str = unitString (moduleUnit mod)
2513 mod_str = moduleNameString (moduleName mod)
2514 occ_str = occNameString occ
2515 occ = nameOccName name
2516 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
2517 | OccName.isVarOcc occ = TH.mkNameG_v
2518 | OccName.isTcOcc occ = TH.mkNameG_tc
2519 | otherwise = pprPanic "reifyName" (ppr name)
2520
2521 -- See Note [Reifying field labels]
2522 reifyFieldLabel :: FieldLabel -> TH.Name
2523 reifyFieldLabel fl
2524 | flIsOverloaded fl
2525 = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))
2526 | otherwise = TH.mkNameG_v pkg_str mod_str occ_str
2527 where
2528 name = flSelector fl
2529 mod = assert (isExternalName name) $ nameModule name
2530 pkg_str = unitString (moduleUnit mod)
2531 mod_str = moduleNameString (moduleName mod)
2532 occ_str = unpackFS (flLabel fl)
2533
2534 reifySelector :: Id -> TyCon -> TH.Name
2535 reifySelector id tc
2536 = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of
2537 Just fl -> reifyFieldLabel fl
2538 Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
2539
2540 ------------------------------
2541 reifyFixity :: Name -> TcM (Maybe TH.Fixity)
2542 reifyFixity name
2543 = do { (found, fix) <- lookupFixityRn_help name
2544 ; return (if found then Just (conv_fix fix) else Nothing) }
2545 where
2546 conv_fix (Hs.Fixity _ i d) = TH.Fixity i (conv_dir d)
2547 conv_dir Hs.InfixR = TH.InfixR
2548 conv_dir Hs.InfixL = TH.InfixL
2549 conv_dir Hs.InfixN = TH.InfixN
2550
2551 reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness
2552 reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness
2553 reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack
2554 reifyUnpackedness SrcUnpack = TH.SourceUnpack
2555
2556 reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness
2557 reifyStrictness NoSrcStrict = TH.NoSourceStrictness
2558 reifyStrictness SrcStrict = TH.SourceStrict
2559 reifyStrictness SrcLazy = TH.SourceLazy
2560
2561 reifySourceBang :: DataCon.HsSrcBang
2562 -> (TH.SourceUnpackedness, TH.SourceStrictness)
2563 reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)
2564
2565 reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness
2566 reifyDecidedStrictness HsLazy = TH.DecidedLazy
2567 reifyDecidedStrictness HsStrict = TH.DecidedStrict
2568 reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack
2569
2570 reifyTypeOfThing :: TH.Name -> TcM TH.Type
2571 reifyTypeOfThing th_name = do
2572 thing <- getThing th_name
2573 case thing of
2574 AGlobal (AnId id) -> reifyType (idType id)
2575 AGlobal (ATyCon tc) -> reifyKind (tyConKind tc)
2576 AGlobal (AConLike (RealDataCon dc)) ->
2577 reifyType (idType (dataConWrapId dc))
2578 AGlobal (AConLike (PatSynCon ps)) ->
2579 reifyPatSynType (patSynSigBndr ps)
2580 ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType
2581 ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType
2582 -- Impossible cases, supposedly:
2583 AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom"
2584 ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon"
2585 APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr"
2586
2587 ------------------------------
2588 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
2589 lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
2590 lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
2591 = return $ ModuleTarget $
2592 mkModule (stringToUnit $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
2593
2594 reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
2595 reifyAnnotations th_name
2596 = do { name <- lookupThAnnLookup th_name
2597 ; topEnv <- getTopEnv
2598 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
2599 ; tcg <- getGblEnv
2600 ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
2601 ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
2602 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
2603
2604 ------------------------------
2605 modToTHMod :: Module -> TH.Module
2606 modToTHMod m = TH.Module (TH.PkgName $ unitString $ moduleUnit m)
2607 (TH.ModName $ moduleNameString $ moduleName m)
2608
2609 reifyModule :: TH.Module -> TcM TH.ModuleInfo
2610 reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
2611 this_mod <- getModule
2612 let reifMod = mkModule (stringToUnit pkgString) (mkModuleName mString)
2613 if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
2614 where
2615 reifyThisModule = do
2616 usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
2617 return $ TH.ModuleInfo usages
2618
2619 reifyFromIface reifMod = do
2620 iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod
2621 let usages = [modToTHMod m | usage <- mi_usages iface,
2622 Just m <- [usageToModule (moduleUnit reifMod) usage] ]
2623 return $ TH.ModuleInfo usages
2624
2625 usageToModule :: Unit -> Usage -> Maybe Module
2626 usageToModule _ (UsageFile {}) = Nothing
2627 usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
2628 usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
2629 usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m
2630 usageToModule this_pkg (UsageHomeModuleInterface { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
2631
2632 ------------------------------
2633 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
2634 mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys
2635
2636 noTH :: SDoc -> SDoc -> TcM a
2637 noTH s d = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
2638 (hsep [text "Can't represent" <+> s <+>
2639 text "in Template Haskell:",
2640 nest 2 d])
2641
2642 ppr_th :: TH.Ppr a => a -> SDoc
2643 ppr_th x = text (TH.pprint x)
2644
2645 {-
2646 Note [Reifying field labels]
2647 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2648 When reifying a datatype declared with DuplicateRecordFields enabled, we want
2649 the reified names of the fields to be labels rather than selector functions.
2650 That is, we want (reify ''T) and (reify 'foo) to produce
2651
2652 data T = MkT { foo :: Int }
2653 foo :: T -> Int
2654
2655 rather than
2656
2657 data T = MkT { $sel:foo:MkT :: Int }
2658 $sel:foo:MkT :: T -> Int
2659
2660 because otherwise TH code that uses the field names as strings will silently do
2661 the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather
2662 than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the
2663 environment, NameG can't be used to represent such fields. Instead,
2664 reifyFieldLabel uses NameQ.
2665
2666 However, this means that extracting the field name from the output of reify, and
2667 trying to reify it again, may fail with an ambiguity error if there are multiple
2668 such fields defined in the module (see the test case
2669 overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to
2670 the TH AST to make it able to represent duplicate record fields.
2671 -}
2672
2673 tcGetInterp :: TcM Interp
2674 tcGetInterp = do
2675 hsc_env <- getTopEnv
2676 case hsc_interp hsc_env of
2677 Nothing -> liftIO $ throwIO (InstallationError "Template haskell requires a target code interpreter")
2678 Just i -> pure i