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