Run typed splices in the zonker
[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, runTopSplice
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 ; q_expr <- tcTopSpliceExpr Typed $
495 tcMonoExpr expr (mkCheckExpType meta_exp_ty)
496 ; lcl_env <- getLclEnv
497 ; let delayed_splice
498 = DelayedSplice lcl_env expr res_ty q_expr
499 ; return (HsSpliceE noExt (HsSplicedT delayed_splice))
500
501 }
502
503
504 -- This is called in the zonker
505 -- See Note [Running typed splices in the zonker]
506 runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
507 runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)
508 = setLclEnv lcl_env $ do {
509 zonked_ty <- zonkTcType res_ty
510 ; zonked_q_expr <- zonkTopLExpr q_expr
511 -- See Note [Collecting modFinalizers in typed splices].
512 ; modfinalizers_ref <- newTcRef []
513 -- Run the expression
514 ; expr2 <- setStage (RunSplice modfinalizers_ref) $
515 runMetaE zonked_q_expr
516 ; mod_finalizers <- readTcRef modfinalizers_ref
517 ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
518 -- We use orig_expr here and not q_expr when tracing as a call to
519 -- unsafeTExpCoerce is added to the original expression by the
520 -- typechecker when typed quotes are type checked.
521 ; traceSplice (SpliceInfo { spliceDescription = "expression"
522 , spliceIsDecl = False
523 , spliceSource = Just orig_expr
524 , spliceGenerated = ppr expr2 })
525 -- Rename and typecheck the spliced-in expression,
526 -- making sure it has type res_ty
527 -- These steps should never fail; this is a *typed* splice
528 ; addErrCtxt (spliceResultDoc zonked_q_expr) $ do
529 { (exp3, _fvs) <- rnLExpr expr2
530 ; unLoc <$> tcMonoExpr exp3 (mkCheckExpType zonked_ty)} }
531
532
533 {-
534 ************************************************************************
535 * *
536 \subsection{Error messages}
537 * *
538 ************************************************************************
539 -}
540
541 spliceCtxtDoc :: HsSplice GhcRn -> SDoc
542 spliceCtxtDoc splice
543 = hang (text "In the Template Haskell splice")
544 2 (pprSplice splice)
545
546 spliceResultDoc :: LHsExpr GhcTc -> SDoc
547 spliceResultDoc expr
548 = sep [ text "In the result of the splice:"
549 , nest 2 (char '$' <> ppr expr)
550 , text "To see what the splice expanded to, use -ddump-splices"]
551
552 -------------------
553 tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
554 -- Note [How top-level splices are handled]
555 -- Type check an expression that is the body of a top-level splice
556 -- (the caller will compile and run it)
557 -- Note that set the level to Splice, regardless of the original level,
558 -- before typechecking the expression. For example:
559 -- f x = $( ...$(g 3) ... )
560 -- The recursive call to tcPolyExpr will simply expand the
561 -- inner escape before dealing with the outer one
562
563 tcTopSpliceExpr isTypedSplice tc_action
564 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
565 -- if the type checker fails!
566 unsetGOptM Opt_DeferTypeErrors $
567 -- Don't defer type errors. Not only are we
568 -- going to run this code, but we do an unsafe
569 -- coerce, so we get a seg-fault if, say we
570 -- splice a type into a place where an expression
571 -- is expected (Trac #7276)
572 setStage (Splice isTypedSplice) $
573 do { -- Typecheck the expression
574 (expr', wanted) <- captureConstraints tc_action
575 ; const_binds <- simplifyTop wanted
576
577 -- Zonk it and tie the knot of dictionary bindings
578 ; return $ mkHsDictLet (EvBinds const_binds) expr' }
579
580 {-
581 ************************************************************************
582 * *
583 Annotations
584 * *
585 ************************************************************************
586 -}
587
588 runAnnotation target expr = do
589 -- Find the classes we want instances for in order to call toAnnotationWrapper
590 loc <- getSrcSpanM
591 data_class <- tcLookupClass dataClassName
592 to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
593
594 -- Check the instances we require live in another module (we want to execute it..)
595 -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
596 -- also resolves the LIE constraints to detect e.g. instance ambiguity
597 zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped (
598 do { (expr', expr_ty) <- tcInferRhoNC expr
599 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
600 -- By instantiating the call >here< it gets registered in the
601 -- LIE consulted by tcTopSpliceExpr
602 -- and hence ensures the appropriate dictionary is bound by const_binds
603 ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
604 ; let specialised_to_annotation_wrapper_expr
605 = L loc (mkHsWrap wrapper
606 (HsVar noExt (L loc to_annotation_wrapper_id)))
607 ; return (L loc (HsApp noExt
608 specialised_to_annotation_wrapper_expr expr'))
609 })
610
611 -- Run the appropriately wrapped expression to get the value of
612 -- the annotation and its dictionaries. The return value is of
613 -- type AnnotationWrapper by construction, so this conversion is
614 -- safe
615 serialized <- runMetaAW zonked_wrapped_expr'
616 return Annotation {
617 ann_target = target,
618 ann_value = serialized
619 }
620
621 convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)
622 convertAnnotationWrapper fhv = do
623 dflags <- getDynFlags
624 if gopt Opt_ExternalInterpreter dflags
625 then do
626 Right <$> runTH THAnnWrapper fhv
627 else do
628 annotation_wrapper <- liftIO $ wormhole dflags fhv
629 return $ Right $
630 case unsafeCoerce# annotation_wrapper of
631 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
632 -- Got the value and dictionaries: build the serialized value and
633 -- call it a day. We ensure that we seq the entire serialized value
634 -- in order that any errors in the user-written code for the
635 -- annotation are exposed at this point. This is also why we are
636 -- doing all this stuff inside the context of runMeta: it has the
637 -- facilities to deal with user error in a meta-level expression
638 seqSerialized serialized `seq` serialized
639
640 -- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
641 seqSerialized :: Serialized -> ()
642 seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
643
644
645 {-
646 ************************************************************************
647 * *
648 \subsection{Running an expression}
649 * *
650 ************************************************************************
651 -}
652
653 runQuasi :: TH.Q a -> TcM a
654 runQuasi act = TH.runQ act
655
656 runRemoteModFinalizers :: ThModFinalizers -> TcM ()
657 runRemoteModFinalizers (ThModFinalizers finRefs) = do
658 dflags <- getDynFlags
659 let withForeignRefs [] f = f []
660 withForeignRefs (x : xs) f = withForeignRef x $ \r ->
661 withForeignRefs xs $ \rs -> f (r : rs)
662 if gopt Opt_ExternalInterpreter dflags then do
663 hsc_env <- env_top <$> getEnv
664 withIServ hsc_env $ \i -> do
665 tcg <- getGblEnv
666 th_state <- readTcRef (tcg_th_remote_state tcg)
667 case th_state of
668 Nothing -> return () -- TH was not started, nothing to do
669 Just fhv -> do
670 liftIO $ withForeignRef fhv $ \st ->
671 withForeignRefs finRefs $ \qrefs ->
672 writeIServ i (putMessage (RunModFinalizers st qrefs))
673 () <- runRemoteTH i []
674 readQResult i
675 else do
676 qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
677 runQuasi $ sequence_ qs
678
679 runQResult
680 :: (a -> String)
681 -> (SrcSpan -> a -> b)
682 -> (ForeignHValue -> TcM a)
683 -> SrcSpan
684 -> ForeignHValue {- TH.Q a -}
685 -> TcM b
686 runQResult show_th f runQ expr_span hval
687 = do { th_result <- runQ hval
688 ; traceTc "Got TH result:" (text (show_th th_result))
689 ; return (f expr_span th_result) }
690
691
692 -----------------
693 runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn)
694 -> LHsExpr GhcTc
695 -> TcM hs_syn
696 runMeta unwrap e
697 = do { h <- getHooked runMetaHook defaultRunMeta
698 ; unwrap h e }
699
700 defaultRunMeta :: MetaHook TcM
701 defaultRunMeta (MetaE r)
702 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)
703 defaultRunMeta (MetaP r)
704 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)
705 defaultRunMeta (MetaT r)
706 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)
707 defaultRunMeta (MetaD r)
708 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)
709 defaultRunMeta (MetaAW r)
710 = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)
711 -- We turn off showing the code in meta-level exceptions because doing so exposes
712 -- the toAnnotationWrapper function that we slap around the user's code
713
714 ----------------
715 runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper
716 -> TcM Serialized
717 runMetaAW = runMeta metaRequestAW
718
719 runMetaE :: LHsExpr GhcTc -- Of type (Q Exp)
720 -> TcM (LHsExpr GhcPs)
721 runMetaE = runMeta metaRequestE
722
723 runMetaP :: LHsExpr GhcTc -- Of type (Q Pat)
724 -> TcM (LPat GhcPs)
725 runMetaP = runMeta metaRequestP
726
727 runMetaT :: LHsExpr GhcTc -- Of type (Q Type)
728 -> TcM (LHsType GhcPs)
729 runMetaT = runMeta metaRequestT
730
731 runMetaD :: LHsExpr GhcTc -- Of type Q [Dec]
732 -> TcM [LHsDecl GhcPs]
733 runMetaD = runMeta metaRequestD
734
735 ---------------
736 runMeta' :: Bool -- Whether code should be printed in the exception message
737 -> (hs_syn -> SDoc) -- how to print the code
738 -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x
739 -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or
740 -- something like that
741 -> TcM hs_syn -- Of type t
742 runMeta' show_code ppr_hs run_and_convert expr
743 = do { traceTc "About to run" (ppr expr)
744 ; recordThSpliceUse -- seems to be the best place to do this,
745 -- we catch all kinds of splices and annotations.
746
747 -- Check that we've had no errors of any sort so far.
748 -- For example, if we found an error in an earlier defn f, but
749 -- recovered giving it type f :: forall a.a, it'd be very dodgy
750 -- to carry ont. Mind you, the staging restrictions mean we won't
751 -- actually run f, but it still seems wrong. And, more concretely,
752 -- see Trac #5358 for an example that fell over when trying to
753 -- reify a function with a "?" kind in it. (These don't occur
754 -- in type-correct programs.
755 ; failIfErrsM
756
757 -- run plugins
758 ; hsc_env <- getTopEnv
759 ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr
760
761 -- Desugar
762 ; ds_expr <- initDsTc (dsLExpr expr')
763 -- Compile and link it; might fail if linking fails
764 ; src_span <- getSrcSpanM
765 ; traceTc "About to run (desugared)" (ppr ds_expr)
766 ; either_hval <- tryM $ liftIO $
767 HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
768 ; case either_hval of {
769 Left exn -> fail_with_exn "compile and link" exn ;
770 Right hval -> do
771
772 { -- Coerce it to Q t, and run it
773
774 -- Running might fail if it throws an exception of any kind (hence tryAllM)
775 -- including, say, a pattern-match exception in the code we are running
776 --
777 -- We also do the TH -> HS syntax conversion inside the same
778 -- exception-cacthing thing so that if there are any lurking
779 -- exceptions in the data structure returned by hval, we'll
780 -- encounter them inside the try
781 --
782 -- See Note [Exceptions in TH]
783 let expr_span = getLoc expr
784 ; either_tval <- tryAllM $
785 setSrcSpan expr_span $ -- Set the span so that qLocation can
786 -- see where this splice is
787 do { mb_result <- run_and_convert expr_span hval
788 ; case mb_result of
789 Left err -> failWithTc err
790 Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
791 ; return $! result } }
792
793 ; case either_tval of
794 Right v -> return v
795 Left se -> case fromException se of
796 Just IOEnvFailure -> failM -- Error already in Tc monad
797 _ -> fail_with_exn "run" se -- Exception
798 }}}
799 where
800 -- see Note [Concealed TH exceptions]
801 fail_with_exn :: Exception e => String -> e -> TcM a
802 fail_with_exn phase exn = do
803 exn_msg <- liftIO $ Panic.safeShowException exn
804 let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
805 nest 2 (text exn_msg),
806 if show_code then text "Code:" <+> ppr expr else empty]
807 failWithTc msg
808
809 {-
810 Note [Running typed splices in the zonker]
811 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
812
813 See #15471 for the full discussion.
814
815 For many years typed splices were run immediately after they were type checked
816 however, this is too early as it means to zonk some type variables before
817 they can be unified with type variables in the surrounding context.
818
819 For example,
820
821 ```
822 module A where
823
824 test_foo :: forall a . Q (TExp (a -> a))
825 test_foo = [|| id ||]
826
827 module B where
828
829 import A
830
831 qux = $$(test_foo)
832 ```
833
834 We would expect `qux` to have inferred type `forall a . a -> a` but if
835 we run the splices too early the unified variables are zonked to `Any`. The
836 inferred type is the unusable `Any -> Any`.
837
838 To run the splice, we must compile `test_foo` all the way to byte code.
839 But at the moment when the type checker is looking at the splice, test_foo
840 has type `Q (TExp (alpha -> alpha))` and we
841 certainly can't compile code involving unification variables!
842
843 We could default `alpha` to `Any` but then we infer `qux :: Any -> Any`
844 which definitely is not what we want. Moreover, if we had
845 qux = [$$(test_foo), (\x -> x +1::Int)]
846 then `alpha` would have to be `Int`.
847
848 Conclusion: we must defer taking decisions about `alpha` until the
849 typechecker is done; and *then* we can run the splice. It's fine to do it
850 later, because we know it'll produce type-correct code.
851
852 Deferring running the splice until later, in the zonker, means that the
853 unification variables propagate upwards from the splice into the surrounding
854 context and are unified correctly.
855
856 This is implemented by storing the arguments we need for running the splice
857 in a `DelayedSplice`. In the zonker, the arguments are passed to
858 `TcSplice.runTopSplice` and the expression inserted into the AST as normal.
859
860
861
862 Note [Exceptions in TH]
863 ~~~~~~~~~~~~~~~~~~~~~~~
864 Suppose we have something like this
865 $( f 4 )
866 where
867 f :: Int -> Q [Dec]
868 f n | n>3 = fail "Too many declarations"
869 | otherwise = ...
870
871 The 'fail' is a user-generated failure, and should be displayed as a
872 perfectly ordinary compiler error message, not a panic or anything
873 like that. Here's how it's processed:
874
875 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
876 effectively transforms (fail s) to
877 qReport True s >> fail
878 where 'qReport' comes from the Quasi class and fail from its monad
879 superclass.
880
881 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
882 (qReport True s) by using addErr to add an error message to the bag of errors.
883 The 'fail' in TcM raises an IOEnvFailure exception
884
885 * 'qReport' forces the message to ensure any exception hidden in unevaluated
886 thunk doesn't get into the bag of errors. Otherwise the following splice
887 will triger panic (Trac #8987):
888 $(fail undefined)
889 See also Note [Concealed TH exceptions]
890
891 * So, when running a splice, we catch all exceptions; then for
892 - an IOEnvFailure exception, we assume the error is already
893 in the error-bag (above)
894 - other errors, we add an error to the bag
895 and then fail
896
897 Note [Concealed TH exceptions]
898 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
899 When displaying the error message contained in an exception originated from TH
900 code, we need to make sure that the error message itself does not contain an
901 exception. For example, when executing the following splice:
902
903 $( error ("foo " ++ error "bar") )
904
905 the message for the outer exception is a thunk which will throw the inner
906 exception when evaluated.
907
908 For this reason, we display the message of a TH exception using the
909 'safeShowException' function, which recursively catches any exception thrown
910 when showing an error message.
911
912
913 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
914 -}
915
916 instance TH.Quasi TcM where
917 qNewName s = do { u <- newUnique
918 ; let i = getKey u
919 ; return (TH.mkNameU s i) }
920
921 -- 'msg' is forced to ensure exceptions don't escape,
922 -- see Note [Exceptions in TH]
923 qReport True msg = seqList msg $ addErr (text msg)
924 qReport False msg = seqList msg $ addWarn NoReason (text msg)
925
926 qLocation = do { m <- getModule
927 ; l <- getSrcSpanM
928 ; r <- case l of
929 UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
930 (ppr l)
931 RealSrcSpan s -> return s
932 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
933 , TH.loc_module = moduleNameString (moduleName m)
934 , TH.loc_package = unitIdString (moduleUnitId m)
935 , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
936 , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
937
938 qLookupName = lookupName
939 qReify = reify
940 qReifyFixity nm = lookupThName nm >>= reifyFixity
941 qReifyInstances = reifyInstances
942 qReifyRoles = reifyRoles
943 qReifyAnnotations = reifyAnnotations
944 qReifyModule = reifyModule
945 qReifyConStrictness nm = do { nm' <- lookupThName nm
946 ; dc <- tcLookupDataCon nm'
947 ; let bangs = dataConImplBangs dc
948 ; return (map reifyDecidedStrictness bangs) }
949
950 -- For qRecover, discard error messages if
951 -- the recovery action is chosen. Otherwise
952 -- we'll only fail higher up.
953 qRecover recover main = tryTcDiscardingErrs recover main
954
955 qAddDependentFile fp = do
956 ref <- fmap tcg_dependent_files getGblEnv
957 dep_files <- readTcRef ref
958 writeTcRef ref (fp:dep_files)
959
960 qAddTempFile suffix = do
961 dflags <- getDynFlags
962 liftIO $ newTempName dflags TFL_GhcSession suffix
963
964 qAddTopDecls thds = do
965 l <- getSrcSpanM
966 let either_hval = convertToHsDecls l thds
967 ds <- case either_hval of
968 Left exn -> failWithTc $
969 hang (text "Error in a declaration passed to addTopDecls:")
970 2 exn
971 Right ds -> return ds
972 mapM_ (checkTopDecl . unLoc) ds
973 th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
974 updTcRef th_topdecls_var (\topds -> ds ++ topds)
975 where
976 checkTopDecl :: HsDecl GhcPs -> TcM ()
977 checkTopDecl (ValD _ binds)
978 = mapM_ bindName (collectHsBindBinders binds)
979 checkTopDecl (SigD _ _)
980 = return ()
981 checkTopDecl (AnnD _ _)
982 = return ()
983 checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))
984 = bindName name
985 checkTopDecl _
986 = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"
987
988 bindName :: RdrName -> TcM ()
989 bindName (Exact n)
990 = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
991 ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
992 }
993
994 bindName name =
995 addErr $
996 hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))
997 2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
998
999 qAddForeignFilePath lang fp = do
1000 var <- fmap tcg_th_foreign_files getGblEnv
1001 updTcRef var ((lang, fp) :)
1002
1003 qAddModFinalizer fin = do
1004 r <- liftIO $ mkRemoteRef fin
1005 fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
1006 addModFinalizerRef fref
1007
1008 qAddCorePlugin plugin = do
1009 hsc_env <- env_top <$> getEnv
1010 r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)
1011 let err = hang
1012 (text "addCorePlugin: invalid plugin module "
1013 <+> text (show plugin)
1014 )
1015 2
1016 (text "Plugins in the current package can't be specified.")
1017 case r of
1018 Found {} -> addErr err
1019 FoundMultiple {} -> addErr err
1020 _ -> return ()
1021 th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
1022 updTcRef th_coreplugins_var (plugin:)
1023
1024 qGetQ :: forall a. Typeable a => TcM (Maybe a)
1025 qGetQ = do
1026 th_state_var <- fmap tcg_th_state getGblEnv
1027 th_state <- readTcRef th_state_var
1028 -- See #10596 for why we use a scoped type variable here.
1029 return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
1030
1031 qPutQ x = do
1032 th_state_var <- fmap tcg_th_state getGblEnv
1033 updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
1034
1035 qIsExtEnabled = xoptM
1036
1037 qExtsEnabled =
1038 EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
1039
1040 -- | Adds a mod finalizer reference to the local environment.
1041 addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
1042 addModFinalizerRef finRef = do
1043 th_stage <- getStage
1044 case th_stage of
1045 RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)
1046 -- This case happens only if a splice is executed and the caller does
1047 -- not set the 'ThStage' to 'RunSplice' to collect finalizers.
1048 -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
1049 _ ->
1050 pprPanic "addModFinalizer was called when no finalizers were collected"
1051 (ppr th_stage)
1052
1053 -- | Releases the external interpreter state.
1054 finishTH :: TcM ()
1055 finishTH = do
1056 dflags <- getDynFlags
1057 when (gopt Opt_ExternalInterpreter dflags) $ do
1058 tcg <- getGblEnv
1059 writeTcRef (tcg_th_remote_state tcg) Nothing
1060
1061 runTHExp :: ForeignHValue -> TcM TH.Exp
1062 runTHExp = runTH THExp
1063
1064 runTHPat :: ForeignHValue -> TcM TH.Pat
1065 runTHPat = runTH THPat
1066
1067 runTHType :: ForeignHValue -> TcM TH.Type
1068 runTHType = runTH THType
1069
1070 runTHDec :: ForeignHValue -> TcM [TH.Dec]
1071 runTHDec = runTH THDec
1072
1073 runTH :: Binary a => THResultType -> ForeignHValue -> TcM a
1074 runTH ty fhv = do
1075 hsc_env <- env_top <$> getEnv
1076 dflags <- getDynFlags
1077 if not (gopt Opt_ExternalInterpreter dflags)
1078 then do
1079 -- Run it in the local TcM
1080 hv <- liftIO $ wormhole dflags fhv
1081 r <- runQuasi (unsafeCoerce# hv :: TH.Q a)
1082 return r
1083 else
1084 -- Run it on the server. For an overview of how TH works with
1085 -- Remote GHCi, see Note [Remote Template Haskell] in
1086 -- libraries/ghci/GHCi/TH.hs.
1087 withIServ hsc_env $ \i -> do
1088 rstate <- getTHState i
1089 loc <- TH.qLocation
1090 liftIO $
1091 withForeignRef rstate $ \state_hv ->
1092 withForeignRef fhv $ \q_hv ->
1093 writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))
1094 runRemoteTH i []
1095 bs <- readQResult i
1096 return $! runGet get (LB.fromStrict bs)
1097
1098
1099 -- | communicate with a remotely-running TH computation until it finishes.
1100 -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
1101 runRemoteTH
1102 :: IServ
1103 -> [Messages] -- saved from nested calls to qRecover
1104 -> TcM ()
1105 runRemoteTH iserv recovers = do
1106 THMsg msg <- liftIO $ readIServ iserv getTHMessage
1107 case msg of
1108 RunTHDone -> return ()
1109 StartRecover -> do -- Note [TH recover with -fexternal-interpreter]
1110 v <- getErrsVar
1111 msgs <- readTcRef v
1112 writeTcRef v emptyMessages
1113 runRemoteTH iserv (msgs : recovers)
1114 EndRecover caught_error -> do
1115 let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of
1116 [] -> panic "EndRecover"
1117 a : b -> (a,b)
1118 v <- getErrsVar
1119 (warn_msgs,_) <- readTcRef v
1120 -- keep the warnings only if there were no errors
1121 writeTcRef v $ if caught_error
1122 then prev_msgs
1123 else (prev_warns `unionBags` warn_msgs, prev_errs)
1124 runRemoteTH iserv rest
1125 _other -> do
1126 r <- handleTHMessage msg
1127 liftIO $ writeIServ iserv (put r)
1128 runRemoteTH iserv recovers
1129
1130 -- | Read a value of type QResult from the iserv
1131 readQResult :: Binary a => IServ -> TcM a
1132 readQResult i = do
1133 qr <- liftIO $ readIServ i get
1134 case qr of
1135 QDone a -> return a
1136 QException str -> liftIO $ throwIO (ErrorCall str)
1137 QFail str -> fail str
1138
1139 {- Note [TH recover with -fexternal-interpreter]
1140
1141 Recover is slightly tricky to implement.
1142
1143 The meaning of "recover a b" is
1144 - Do a
1145 - If it finished with no errors, then keep the warnings it generated
1146 - If it failed, discard any messages it generated, and do b
1147
1148 Note that "failed" here can mean either
1149 (1) threw an exception (failTc)
1150 (2) generated an error message (addErrTcM)
1151
1152 The messages are managed by GHC in the TcM monad, whereas the
1153 exception-handling is done in the ghc-iserv process, so we have to
1154 coordinate between the two.
1155
1156 On the server:
1157 - emit a StartRecover message
1158 - run "a; FailIfErrs" inside a try
1159 - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed
1160 - if "a; FailIfErrs" failed, run "b"
1161
1162 Back in GHC, when we receive:
1163
1164 FailIfErrrs
1165 failTc if there are any error messages (= failIfErrsM)
1166 StartRecover
1167 save the current messages and start with an empty set.
1168 EndRecover caught_error
1169 Restore the previous messages,
1170 and merge in the new messages if caught_error is false.
1171 -}
1172
1173 -- | Retrieve (or create, if it hasn't been created already), the
1174 -- remote TH state. The TH state is a remote reference to an IORef
1175 -- QState living on the server, and we have to pass this to each RunTH
1176 -- call we make.
1177 --
1178 -- The TH state is stored in tcg_th_remote_state in the TcGblEnv.
1179 --
1180 getTHState :: IServ -> TcM (ForeignRef (IORef QState))
1181 getTHState i = do
1182 tcg <- getGblEnv
1183 th_state <- readTcRef (tcg_th_remote_state tcg)
1184 case th_state of
1185 Just rhv -> return rhv
1186 Nothing -> do
1187 hsc_env <- env_top <$> getEnv
1188 fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH
1189 writeTcRef (tcg_th_remote_state tcg) (Just fhv)
1190 return fhv
1191
1192 wrapTHResult :: TcM a -> TcM (THResult a)
1193 wrapTHResult tcm = do
1194 e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic
1195 case e of
1196 Left e -> return (THException (show e))
1197 Right a -> return (THComplete a)
1198
1199 handleTHMessage :: THMessage a -> TcM a
1200 handleTHMessage msg = case msg of
1201 NewName a -> wrapTHResult $ TH.qNewName a
1202 Report b str -> wrapTHResult $ TH.qReport b str
1203 LookupName b str -> wrapTHResult $ TH.qLookupName b str
1204 Reify n -> wrapTHResult $ TH.qReify n
1205 ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
1206 ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
1207 ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
1208 ReifyAnnotations lookup tyrep ->
1209 wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
1210 ReifyModule m -> wrapTHResult $ TH.qReifyModule m
1211 ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
1212 AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
1213 AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
1214 AddModFinalizer r -> do
1215 hsc_env <- env_top <$> getEnv
1216 wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
1217 AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
1218 AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
1219 AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
1220 IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
1221 ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
1222 FailIfErrs -> wrapTHResult failIfErrsM
1223 _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
1224
1225 getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
1226 getAnnotationsByTypeRep th_name tyrep
1227 = do { name <- lookupThAnnLookup th_name
1228 ; topEnv <- getTopEnv
1229 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1230 ; tcg <- getGblEnv
1231 ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep
1232 ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep
1233 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1234
1235 {-
1236 ************************************************************************
1237 * *
1238 Instance Testing
1239 * *
1240 ************************************************************************
1241 -}
1242
1243 reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
1244 reifyInstances th_nm th_tys
1245 = addErrCtxt (text "In the argument of reifyInstances:"
1246 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
1247 do { loc <- getSrcSpanM
1248 ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)
1249 -- #9262 says to bring vars into scope, like in HsForAllTy case
1250 -- of rnHsTyKi
1251 ; let tv_rdrs = freeKiTyVarsAllVars (extractHsTyRdrTyVars rdr_ty)
1252 -- Rename to HsType Name
1253 ; ((tv_names, rn_ty), _fvs)
1254 <- checkNoErrs $ -- If there are out-of-scope Names here, then we
1255 -- must error before proceeding to typecheck the
1256 -- renamed type, as that will result in GHC
1257 -- internal errors (#13837).
1258 bindLRdrNames tv_rdrs $ \ tv_names ->
1259 do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
1260 ; return ((tv_names, rn_ty), fvs) }
1261 ; (_tvs, ty)
1262 <- pushTcLevelM_ $
1263 solveEqualities $ -- Avoid error cascade if there are unsolved
1264 bindImplicitTKBndrs_Skol tv_names $
1265 fst <$> tcLHsType rn_ty
1266 ; ty <- zonkTcTypeToType ty
1267 -- Substitute out the meta type variables
1268 -- In particular, the type might have kind
1269 -- variables inside it (Trac #7477)
1270
1271 ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty))
1272 ; case splitTyConApp_maybe ty of -- This expands any type synonyms
1273 Just (tc, tys) -- See Trac #7910
1274 | Just cls <- tyConClass_maybe tc
1275 -> do { inst_envs <- tcGetInstEnvs
1276 ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys
1277 ; traceTc "reifyInstances1" (ppr matches)
1278 ; reifyClassInstances cls (map fst matches ++ unifies) }
1279 | isOpenFamilyTyCon tc
1280 -> do { inst_envs <- tcGetFamInstEnvs
1281 ; let matches = lookupFamInstEnv inst_envs tc tys
1282 ; traceTc "reifyInstances2" (ppr matches)
1283 ; reifyFamilyInstances tc (map fim_instance matches) }
1284 _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))
1285 2 (text "is not a class constraint or type family application")) }
1286 where
1287 doc = ClassInstanceCtx
1288 bale_out msg = failWithTc msg
1289
1290 cvt :: SrcSpan -> TH.Type -> TcM (LHsType GhcPs)
1291 cvt loc th_ty = case convertToHsType loc th_ty of
1292 Left msg -> failWithTc msg
1293 Right ty -> return ty
1294
1295 {-
1296 ************************************************************************
1297 * *
1298 Reification
1299 * *
1300 ************************************************************************
1301 -}
1302
1303 lookupName :: Bool -- True <=> type namespace
1304 -- False <=> value namespace
1305 -> String -> TcM (Maybe TH.Name)
1306 lookupName is_type_name s
1307 = do { lcl_env <- getLocalRdrEnv
1308 ; case lookupLocalRdrEnv lcl_env rdr_name of
1309 Just n -> return (Just (reifyName n))
1310 Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name
1311 ; return (fmap reifyName mb_nm) } }
1312 where
1313 th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M'
1314
1315 occ_fs :: FastString
1316 occ_fs = mkFastString (TH.nameBase th_name)
1317
1318 occ :: OccName
1319 occ | is_type_name
1320 = if isLexVarSym occ_fs || isLexCon occ_fs
1321 then mkTcOccFS occ_fs
1322 else mkTyVarOccFS occ_fs
1323 | otherwise
1324 = if isLexCon occ_fs then mkDataOccFS occ_fs
1325 else mkVarOccFS occ_fs
1326
1327 rdr_name = case TH.nameModule th_name of
1328 Nothing -> mkRdrUnqual occ
1329 Just mod -> mkRdrQual (mkModuleName mod) occ
1330
1331 getThing :: TH.Name -> TcM TcTyThing
1332 getThing th_name
1333 = do { name <- lookupThName th_name
1334 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
1335 ; tcLookupTh name }
1336 -- ToDo: this tcLookup could fail, which would give a
1337 -- rather unhelpful error message
1338 where
1339 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
1340 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
1341 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
1342 ppr_ns _ = panic "reify/ppr_ns"
1343
1344 reify :: TH.Name -> TcM TH.Info
1345 reify th_name
1346 = do { traceTc "reify 1" (text (TH.showName th_name))
1347 ; thing <- getThing th_name
1348 ; traceTc "reify 2" (ppr thing)
1349 ; reifyThing thing }
1350
1351 lookupThName :: TH.Name -> TcM Name
1352 lookupThName th_name = do
1353 mb_name <- lookupThName_maybe th_name
1354 case mb_name of
1355 Nothing -> failWithTc (notInScope th_name)
1356 Just name -> return name
1357
1358 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
1359 lookupThName_maybe th_name
1360 = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
1361 -- Pick the first that works
1362 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
1363 ; return (listToMaybe names) }
1364 where
1365 lookup rdr_name
1366 = do { -- Repeat much of lookupOccRn, because we want
1367 -- to report errors in a TH-relevant way
1368 ; rdr_env <- getLocalRdrEnv
1369 ; case lookupLocalRdrEnv rdr_env rdr_name of
1370 Just name -> return (Just name)
1371 Nothing -> lookupGlobalOccRn_maybe rdr_name }
1372
1373 tcLookupTh :: Name -> TcM TcTyThing
1374 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
1375 -- it gives a reify-related error message on failure, whereas in the normal
1376 -- tcLookup, failure is a bug.
1377 tcLookupTh name
1378 = do { (gbl_env, lcl_env) <- getEnvs
1379 ; case lookupNameEnv (tcl_env lcl_env) name of {
1380 Just thing -> return thing;
1381 Nothing ->
1382
1383 case lookupNameEnv (tcg_type_env gbl_env) name of {
1384 Just thing -> return (AGlobal thing);
1385 Nothing ->
1386
1387 -- EZY: I don't think this choice matters, no TH in signatures!
1388 if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name
1389 then -- It's defined in this module
1390 failWithTc (notInEnv name)
1391
1392 else
1393 do { mb_thing <- tcLookupImported_maybe name
1394 ; case mb_thing of
1395 Succeeded thing -> return (AGlobal thing)
1396 Failed msg -> failWithTc msg
1397 }}}}
1398
1399 notInScope :: TH.Name -> SDoc
1400 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
1401 text "is not in scope at a reify"
1402 -- Ugh! Rather an indirect way to display the name
1403
1404 notInEnv :: Name -> SDoc
1405 notInEnv name = quotes (ppr name) <+>
1406 text "is not in the type environment at a reify"
1407
1408 ------------------------------
1409 reifyRoles :: TH.Name -> TcM [TH.Role]
1410 reifyRoles th_name
1411 = do { thing <- getThing th_name
1412 ; case thing of
1413 AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
1414 _ -> failWithTc (text "No roles associated with" <+> (ppr thing))
1415 }
1416 where
1417 reify_role Nominal = TH.NominalR
1418 reify_role Representational = TH.RepresentationalR
1419 reify_role Phantom = TH.PhantomR
1420
1421 ------------------------------
1422 reifyThing :: TcTyThing -> TcM TH.Info
1423 -- The only reason this is monadic is for error reporting,
1424 -- which in turn is mainly for the case when TH can't express
1425 -- some random GHC extension
1426
1427 reifyThing (AGlobal (AnId id))
1428 = do { ty <- reifyType (idType id)
1429 ; let v = reifyName id
1430 ; case idDetails id of
1431 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))
1432 RecSelId{sel_tycon=RecSelData tc}
1433 -> return (TH.VarI (reifySelector id tc) ty Nothing)
1434 _ -> return (TH.VarI v ty Nothing)
1435 }
1436
1437 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
1438 reifyThing (AGlobal (AConLike (RealDataCon dc)))
1439 = do { let name = dataConName dc
1440 ; ty <- reifyType (idType (dataConWrapId dc))
1441 ; return (TH.DataConI (reifyName name) ty
1442 (reifyName (dataConOrigTyCon dc)))
1443 }
1444
1445 reifyThing (AGlobal (AConLike (PatSynCon ps)))
1446 = do { let name = reifyName ps
1447 ; ty <- reifyPatSynType (patSynSig ps)
1448 ; return (TH.PatSynI name ty) }
1449
1450 reifyThing (ATcId {tct_id = id})
1451 = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
1452 -- though it may be incomplete
1453 ; ty2 <- reifyType ty1
1454 ; return (TH.VarI (reifyName id) ty2 Nothing) }
1455
1456 reifyThing (ATyVar tv tv1)
1457 = do { ty1 <- zonkTcTyVar tv1
1458 ; ty2 <- reifyType ty1
1459 ; return (TH.TyVarI (reifyName tv) ty2) }
1460
1461 reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
1462
1463 -------------------------------------------
1464 reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
1465 reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
1466 , cab_lhs = lhs
1467 , cab_rhs = rhs })
1468 -- remove kind patterns (#8884)
1469 = do { tvs' <- reifyTyVarsToMaybe tvs
1470 ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
1471 ; lhs' <- reifyTypes lhs_types_only
1472 ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)
1473 lhs_types_only lhs'
1474 ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs
1475 ; rhs' <- reifyType rhs
1476 ; return (TH.TySynEqn tvs' lhs_type rhs') }
1477 where
1478 fam_tvs = tyConVisibleTyVars fam_tc
1479
1480 reifyTyCon :: TyCon -> TcM TH.Info
1481 reifyTyCon tc
1482 | Just cls <- tyConClass_maybe tc
1483 = reifyClass cls
1484
1485 | isFunTyCon tc
1486 = return (TH.PrimTyConI (reifyName tc) 2 False)
1487
1488 | isPrimTyCon tc
1489 = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnliftedTyCon tc))
1490
1491 | isTypeFamilyTyCon tc
1492 = do { let tvs = tyConTyVars tc
1493 res_kind = tyConResKind tc
1494 resVar = famTcResVar tc
1495
1496 ; kind' <- reifyKind res_kind
1497 ; let (resultSig, injectivity) =
1498 case resVar of
1499 Nothing -> (TH.KindSig kind', Nothing)
1500 Just name ->
1501 let thName = reifyName name
1502 injAnnot = tyConInjectivityInfo tc
1503 sig = TH.TyVarSig (TH.KindedTV thName kind')
1504 inj = case injAnnot of
1505 NotInjective -> Nothing
1506 Injective ms ->
1507 Just (TH.InjectivityAnn thName injRHS)
1508 where
1509 injRHS = map (reifyName . tyVarName)
1510 (filterByList ms tvs)
1511 in (sig, inj)
1512 ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
1513 ; let tfHead =
1514 TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity
1515 ; if isOpenTypeFamilyTyCon tc
1516 then do { fam_envs <- tcGetFamInstEnvs
1517 ; instances <- reifyFamilyInstances tc
1518 (familyInstances fam_envs tc)
1519 ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) }
1520 else do { eqns <-
1521 case isClosedSynFamilyTyConWithAxiom_maybe tc of
1522 Just ax -> mapM (reifyAxBranch tc) $
1523 fromBranches $ coAxiomBranches ax
1524 Nothing -> return []
1525 ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns)
1526 []) } }
1527
1528 | isDataFamilyTyCon tc
1529 = do { let res_kind = tyConResKind tc
1530
1531 ; kind' <- fmap Just (reifyKind res_kind)
1532
1533 ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
1534 ; fam_envs <- tcGetFamInstEnvs
1535 ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)
1536 ; return (TH.FamilyI
1537 (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }
1538
1539 | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym
1540 = do { rhs' <- reifyType rhs
1541 ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
1542 ; return (TH.TyConI
1543 (TH.TySynD (reifyName tc) tvs' rhs'))
1544 }
1545
1546 | otherwise
1547 = do { cxt <- reifyCxt (tyConStupidTheta tc)
1548 ; let tvs = tyConTyVars tc
1549 dataCons = tyConDataCons tc
1550 isGadt = isGadtSyntaxTyCon tc
1551 ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
1552 ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc)
1553 ; let name = reifyName tc
1554 deriv = [] -- Don't know about deriving
1555 decl | isNewTyCon tc =
1556 TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv
1557 | otherwise =
1558 TH.DataD cxt name r_tvs Nothing cons deriv
1559 ; return (TH.TyConI decl) }
1560
1561 reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con
1562 reifyDataCon isGadtDataCon tys dc
1563 = do { let -- used for H98 data constructors
1564 (ex_tvs, theta, arg_tys)
1565 = dataConInstSig dc tys
1566 -- used for GADTs data constructors
1567 g_user_tvs' = dataConUserTyVars dc
1568 (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty')
1569 = dataConFullSig dc
1570 (srcUnpks, srcStricts)
1571 = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
1572 dcdBangs = zipWith TH.Bang srcUnpks srcStricts
1573 fields = dataConFieldLabels dc
1574 name = reifyName dc
1575 -- Universal tvs present in eq_spec need to be filtered out, as
1576 -- they will not appear anywhere in the type.
1577 eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec)
1578
1579 ; (univ_subst, _)
1580 -- See Note [Freshen reified GADT constructors' universal tyvars]
1581 <- freshenTyVarBndrs $
1582 filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs
1583 ; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs'
1584 g_theta = substTys tvb_subst g_theta'
1585 g_arg_tys = substTys tvb_subst g_arg_tys'
1586 g_res_ty = substTy tvb_subst g_res_ty'
1587
1588 ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
1589
1590 ; main_con <-
1591 if | not (null fields) && not isGadtDataCon ->
1592 return $ TH.RecC name (zip3 (map reifyFieldLabel fields)
1593 dcdBangs r_arg_tys)
1594 | not (null fields) -> do
1595 { res_ty <- reifyType g_res_ty
1596 ; return $ TH.RecGadtC [name]
1597 (zip3 (map (reifyName . flSelector) fields)
1598 dcdBangs r_arg_tys) res_ty }
1599 -- We need to check not isGadtDataCon here because GADT
1600 -- constructors can be declared infix.
1601 -- See Note [Infix GADT constructors] in TcTyClsDecls.
1602 | dataConIsInfix dc && not isGadtDataCon ->
1603 ASSERT( arg_tys `lengthIs` 2 ) do
1604 { let [r_a1, r_a2] = r_arg_tys
1605 [s1, s2] = dcdBangs
1606 ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
1607 | isGadtDataCon -> do
1608 { res_ty <- reifyType g_res_ty
1609 ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }
1610 | otherwise ->
1611 return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
1612
1613 ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)
1614 | otherwise = ASSERT( all isTyVar ex_tvs )
1615 -- no covars for haskell syntax
1616 (ex_tvs, theta)
1617 ret_con | null ex_tvs' && null theta' = return main_con
1618 | otherwise = do
1619 { cxt <- reifyCxt theta'
1620 ; ex_tvs'' <- reifyTyVars ex_tvs'
1621 ; return (TH.ForallC ex_tvs'' cxt main_con) }
1622 ; ASSERT( arg_tys `equalLength` dcdBangs )
1623 ret_con }
1624
1625 {-
1626 Note [Freshen reified GADT constructors' universal tyvars]
1627 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1628 Suppose one were to reify this GADT:
1629
1630 data a :~: b where
1631 Refl :: forall a b. (a ~ b) => a :~: b
1632
1633 We ought to be careful here about the uniques we give to the occurrences of `a`
1634 and `b` in this definition. That is because in the original DataCon, all uses
1635 of `a` and `b` have the same unique, since `a` and `b` are both universally
1636 quantified type variables--that is, they are used in both the (:~:) tycon as
1637 well as in the constructor type signature. But when we turn the DataCon
1638 definition into the reified one, the `a` and `b` in the constructor type
1639 signature becomes differently scoped than the `a` and `b` in `data a :~: b`.
1640
1641 While it wouldn't technically be *wrong* per se to re-use the same uniques for
1642 `a` and `b` across these two different scopes, it's somewhat annoying for end
1643 users of Template Haskell, since they wouldn't be able to rely on the
1644 assumption that all TH names have globally distinct uniques (#13885). For this
1645 reason, we freshen the universally quantified tyvars that go into the reified
1646 GADT constructor type signature to give them distinct uniques from their
1647 counterparts in the tycon.
1648 -}
1649
1650 ------------------------------
1651 reifyClass :: Class -> TcM TH.Info
1652 reifyClass cls
1653 = do { cxt <- reifyCxt theta
1654 ; inst_envs <- tcGetInstEnvs
1655 ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
1656 ; assocTys <- concatMapM reifyAT ats
1657 ; ops <- concatMapM reify_op op_stuff
1658 ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls))
1659 ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
1660 ; return (TH.ClassI dec insts) }
1661 where
1662 (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
1663 fds' = map reifyFunDep fds
1664 reify_op (op, def_meth)
1665 = do { let (_, _, ty) = tcSplitMethodTy (idType op)
1666 -- Use tcSplitMethodTy to get rid of the extraneous class
1667 -- variables and predicates at the beginning of op's type
1668 -- (see #15551).
1669 ; ty' <- reifyType ty
1670 ; let nm' = reifyName op
1671 ; case def_meth of
1672 Just (_, GenericDM gdm_ty) ->
1673 do { gdm_ty' <- reifyType gdm_ty
1674 ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] }
1675 _ -> return [TH.SigD nm' ty'] }
1676
1677 reifyAT :: ClassATItem -> TcM [TH.Dec]
1678 reifyAT (ATI tycon def) = do
1679 tycon' <- reifyTyCon tycon
1680 case tycon' of
1681 TH.FamilyI dec _ -> do
1682 let (tyName, tyArgs) = tfNames dec
1683 (dec :) <$> maybe (return [])
1684 (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
1685 def
1686 _ -> pprPanic "reifyAT" (text (show tycon'))
1687
1688 reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
1689 reifyDefImpl n args ty =
1690 TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args))
1691 <$> reifyType ty
1692
1693 tfNames :: TH.Dec -> (TH.Name, [TH.Name])
1694 tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
1695 = (n, map bndrName args)
1696 tfNames d = pprPanic "tfNames" (text (show d))
1697
1698 bndrName :: TH.TyVarBndr -> TH.Name
1699 bndrName (TH.PlainTV n) = n
1700 bndrName (TH.KindedTV n _) = n
1701
1702 ------------------------------
1703 -- | Annotate (with TH.SigT) a type if the first parameter is True
1704 -- and if the type contains a free variable.
1705 -- This is used to annotate type patterns for poly-kinded tyvars in
1706 -- reifying class and type instances. See #8953 and th/T8953.
1707 annotThType :: Bool -- True <=> annotate
1708 -> TyCoRep.Type -> TH.Type -> TcM TH.Type
1709 -- tiny optimization: if the type is annotated, don't annotate again.
1710 annotThType _ _ th_ty@(TH.SigT {}) = return th_ty
1711 annotThType True ty th_ty
1712 | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
1713 = do { let ki = tcTypeKind ty
1714 ; th_ki <- reifyKind ki
1715 ; return (TH.SigT th_ty th_ki) }
1716 annotThType _ _ th_ty = return th_ty
1717
1718 -- | For every type variable in the input,
1719 -- report whether or not the tv is poly-kinded. This is used to eventually
1720 -- feed into 'annotThType'.
1721 mkIsPolyTvs :: [TyVar] -> [Bool]
1722 mkIsPolyTvs = map is_poly_tv
1723 where
1724 is_poly_tv tv = not $
1725 isEmptyVarSet $
1726 filterVarSet isTyVar $
1727 tyCoVarsOfType $
1728 tyVarKind tv
1729
1730 ------------------------------
1731 reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
1732 reifyClassInstances cls insts
1733 = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
1734 where
1735 tvs = tyConVisibleTyVars (classTyCon cls)
1736
1737 reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1738 -- includes only *visible* tvs
1739 -> ClsInst -> TcM TH.Dec
1740 reifyClassInstance is_poly_tvs i
1741 = do { cxt <- reifyCxt theta
1742 ; let vis_types = filterOutInvisibleTypes cls_tc types
1743 ; thtypes <- reifyTypes vis_types
1744 ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
1745 ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
1746 ; return $ (TH.InstanceD over cxt head_ty []) }
1747 where
1748 (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
1749 cls_tc = classTyCon cls
1750 dfun = instanceDFunId i
1751 over = case overlapMode (is_flag i) of
1752 NoOverlap _ -> Nothing
1753 Overlappable _ -> Just TH.Overlappable
1754 Overlapping _ -> Just TH.Overlapping
1755 Overlaps _ -> Just TH.Overlaps
1756 Incoherent _ -> Just TH.Incoherent
1757
1758 ------------------------------
1759 reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
1760 reifyFamilyInstances fam_tc fam_insts
1761 = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
1762 where
1763 fam_tvs = tyConVisibleTyVars fam_tc
1764
1765 reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1766 -- includes only *visible* tvs
1767 -> FamInst -> TcM TH.Dec
1768 reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor
1769 , fi_axiom = ax
1770 , fi_fam = fam })
1771 | let fam_tc = coAxiomTyCon ax
1772 branch = coAxiomSingleBranch ax
1773 , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch
1774 = case flavor of
1775 SynFamilyInst ->
1776 -- remove kind patterns (#8884)
1777 do { th_tvs <- reifyTyVarsToMaybe tvs
1778 ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
1779 ; th_lhs <- reifyTypes lhs_types_only
1780 ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
1781 th_lhs
1782 ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs
1783 ; th_rhs <- reifyType rhs
1784 ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) }
1785
1786 DataFamilyInst rep_tc ->
1787 do { let -- eta-expand lhs types, because sometimes data/newtype
1788 -- instances are eta-reduced; See Trac #9692
1789 -- See Note [Eta reduction for data families] in FamInstEnv
1790 (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch
1791 fam' = reifyName fam
1792 dataCons = tyConDataCons rep_tc
1793 isGadt = isGadtSyntaxTyCon rep_tc
1794 ; th_tvs <- reifyTyVarsToMaybe ee_tvs
1795 ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons
1796 ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs
1797 ; th_tys <- reifyTypes types_only
1798 ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
1799 ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys
1800 ; return $
1801 if isNewTyCon rep_tc
1802 then TH.NewtypeInstD [] th_tvs lhs_type Nothing (head cons) []
1803 else TH.DataInstD [] th_tvs lhs_type Nothing cons []
1804 }
1805
1806 ------------------------------
1807 reifyType :: TyCoRep.Type -> TcM TH.Type
1808 -- Monadic only because of failure
1809 reifyType ty | tcIsLiftedTypeKind ty = return TH.StarT
1810 -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it
1811 -- with Constraint (#14869).
1812 reifyType ty@(ForAllTy {}) = reify_for_all ty
1813 reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) }
1814 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1815 reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
1816 reifyType ty@(AppTy {}) = do
1817 let (ty_head, ty_args) = splitAppTys ty
1818 ty_head' <- reifyType ty_head
1819 ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args)
1820 pure $ mkThAppTs ty_head' ty_args'
1821 where
1822 -- Make sure to filter out any invisible arguments. For instance, if you
1823 -- reify the following:
1824 --
1825 -- newtype T (f :: forall a. a -> Type) = MkT (f Bool)
1826 --
1827 -- Then you should receive back `f Bool`, not `f Type Bool`, since the
1828 -- `Type` argument is invisible (#15792).
1829 filter_out_invisible_args :: Type -> [Type] -> [Type]
1830 filter_out_invisible_args ty_head ty_args =
1831 filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)
1832 ty_args
1833 reifyType ty@(FunTy t1 t2)
1834 | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
1835 | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1836 reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH
1837 reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)
1838
1839 reify_for_all :: TyCoRep.Type -> TcM TH.Type
1840 reify_for_all ty
1841 = do { cxt' <- reifyCxt cxt;
1842 ; tau' <- reifyType tau
1843 ; tvs' <- reifyTyVars tvs
1844 ; return (TH.ForallT tvs' cxt' tau') }
1845 where
1846 (tvs, cxt, tau) = tcSplitSigmaTy ty
1847
1848 reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
1849 reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
1850 reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
1851
1852 reifyTypes :: [Type] -> TcM [TH.Type]
1853 reifyTypes = mapM reifyType
1854
1855 reifyPatSynType
1856 :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type
1857 -- reifies a pattern synonym's type and returns its *complete* type
1858 -- signature; see NOTE [Pattern synonym signatures and Template
1859 -- Haskell]
1860 reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
1861 = do { univTyVars' <- reifyTyVars univTyVars
1862 ; req' <- reifyCxt req
1863 ; exTyVars' <- reifyTyVars exTyVars
1864 ; prov' <- reifyCxt prov
1865 ; tau' <- reifyType (mkFunTys argTys resTy)
1866 ; return $ TH.ForallT univTyVars' req'
1867 $ TH.ForallT exTyVars' prov' tau' }
1868
1869 reifyKind :: Kind -> TcM TH.Kind
1870 reifyKind = reifyType
1871
1872 reifyCxt :: [PredType] -> TcM [TH.Pred]
1873 reifyCxt = mapM reifyType
1874
1875 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1876 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1877
1878 reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr]
1879 reifyTyVars tvs = mapM reify_tv tvs
1880 where
1881 -- even if the kind is *, we need to include a kind annotation,
1882 -- in case a poly-kind would be inferred without the annotation.
1883 -- See #8953 or test th/T8953
1884 reify_tv tv = TH.KindedTV name <$> reifyKind kind
1885 where
1886 kind = tyVarKind tv
1887 name = reifyName tv
1888
1889 reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr])
1890 reifyTyVarsToMaybe [] = pure Nothing
1891 reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys
1892
1893 {-
1894 Note [Kind annotations on TyConApps]
1895 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1896 A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.
1897 For example:
1898
1899 type family F a :: k
1900 type instance F Int = (Proxy :: * -> *)
1901 type instance F Bool = (Proxy :: (* -> *) -> *)
1902
1903 It's hard to figure out where these annotations should appear, so we do this:
1904 Suppose we have a tycon application (T ty1 ... tyn). Assuming that T is not
1905 oversatured (more on this later), we can assume T's declaration is of the form
1906 T (tvb1 :: s1) ... (tvbn :: sn) :: p. If any kind variable that
1907 is free in p is not free in an injective position in tvb1 ... tvbn,
1908 then we put on a kind annotation, since we would not otherwise be able to infer
1909 the kind of the whole tycon application.
1910
1911 The injective positions in a tyvar binder are the injective positions in the
1912 kind of its tyvar, provided the tyvar binder is either:
1913
1914 * Anonymous. For example, in the promoted data constructor '(:):
1915
1916 '(:) :: forall a. a -> [a] -> [a]
1917
1918 The second and third tyvar binders (of kinds `a` and `[a]`) are both
1919 anonymous, so if we had '(:) 'True '[], then the inferred kinds of 'True and
1920 '[] would contribute to the inferred kind of '(:) 'True '[].
1921 * Has required visibility. For example, in the type family:
1922
1923 type family Wurble k (a :: k) :: k
1924 Wurble :: forall k -> k -> k
1925
1926 The first tyvar binder (of kind `forall k`) has required visibility, so if
1927 we had Wurble (Maybe a) Nothing, then the inferred kind of Maybe a would
1928 contribute to the inferred kind of Wurble (Maybe a) Nothing.
1929
1930 An injective position in a type is one that does not occur as an argument to
1931 a non-injective type constructor (e.g., non-injective type families). See
1932 injectiveVarsOfType.
1933
1934 How can be sure that this is correct? That is, how can we be sure that in the
1935 event that we leave off a kind annotation, that one could infer the kind of the
1936 tycon application from its arguments? It's essentially a proof by induction: if
1937 we can infer the kinds of every subtree of a type, then the whole tycon
1938 application will have an inferrable kind--unless, of course, the remainder of
1939 the tycon application's kind has uninstantiated kind variables.
1940
1941 An earlier implementation of this algorithm only checked if p contained any
1942 free variables. But this was unsatisfactory, since a datatype like this:
1943
1944 data Foo = Foo (Proxy '[False, True])
1945
1946 Would be reified like this:
1947
1948 data Foo = Foo (Proxy ('(:) False ('(:) True ('[] :: [Bool])
1949 :: [Bool]) :: [Bool]))
1950
1951 Which has a rather excessive amount of kind annotations. With the current
1952 algorithm, we instead reify Foo to this:
1953
1954 data Foo = Foo (Proxy ('(:) False ('(:) True ('[] :: [Bool]))))
1955
1956 Since in the case of '[], the kind p is [a], and there are no arguments in the
1957 kind of '[]. On the other hand, in the case of '(:) True '[], the kind p is
1958 (forall a. [a]), but a occurs free in the first and second arguments of the
1959 full kind of '(:), which is (forall a. a -> [a] -> [a]). (See Trac #14060.)
1960
1961 What happens if T is oversaturated? That is, if T's kind has fewer than n
1962 arguments, in the case that the concrete application instantiates a result
1963 kind variable with an arrow kind? If we run out of arguments, we do not attach
1964 a kind annotation. This should be a rare case, indeed. Here is an example:
1965
1966 data T1 :: k1 -> k2 -> *
1967 data T2 :: k1 -> k2 -> *
1968
1969 type family G (a :: k) :: k
1970 type instance G T1 = T2
1971
1972 type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above
1973
1974 Here G's kind is (forall k. k -> k), and the desugared RHS of that last
1975 instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
1976 the algorithm above, there are 3 arguments to G so we should peel off 3
1977 arguments in G's kind. But G's kind has only two arguments. This is the
1978 rare special case, and we choose not to annotate the application of G with
1979 a kind signature. After all, we needn't do this, since that instance would
1980 be reified as:
1981
1982 type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool
1983
1984 So the kind of G isn't ambiguous anymore due to the explicit kind annotation
1985 on its argument. See #8953 and test th/T8953.
1986 -}
1987
1988 reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
1989 reify_tc_app tc tys
1990 = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
1991 ; maybe_sig_t (mkThAppTs r_tc tys') }
1992 where
1993 arity = tyConArity tc
1994 tc_binders = tyConBinders tc
1995 tc_res_kind = tyConResKind tc
1996
1997 r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2)
1998 | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2)
1999 | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2)
2000 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
2001 | isTupleTyCon tc = if isPromotedDataCon tc
2002 then TH.PromotedTupleT arity
2003 else TH.TupleT arity
2004 | tc `hasKey` constraintKindTyConKey
2005 = TH.ConstraintT
2006 | tc `hasKey` funTyConKey = TH.ArrowT
2007 | tc `hasKey` listTyConKey = TH.ListT
2008 | tc `hasKey` nilDataConKey = TH.PromotedNilT
2009 | tc `hasKey` consDataConKey = TH.PromotedConsT
2010 | tc `hasKey` heqTyConKey = TH.EqualityT
2011 | tc `hasKey` eqPrimTyConKey = TH.EqualityT
2012 | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
2013 | isPromotedDataCon tc = TH.PromotedT (reifyName tc)
2014 | otherwise = TH.ConT (reifyName tc)
2015
2016 -- See Note [Kind annotations on TyConApps]
2017 maybe_sig_t th_type
2018 | needs_kind_sig
2019 = do { let full_kind = tcTypeKind (mkTyConApp tc tys)
2020 ; th_full_kind <- reifyKind full_kind
2021 ; return (TH.SigT th_type th_full_kind) }
2022 | otherwise
2023 = return th_type
2024
2025 needs_kind_sig
2026 | GT <- compareLength tys tc_binders
2027 = False
2028 | otherwise
2029 = let (dropped_binders, remaining_binders)
2030 = splitAtList tys tc_binders
2031 result_kind = mkTyConKind remaining_binders tc_res_kind
2032 result_vars = tyCoVarsOfType result_kind
2033 dropped_vars = fvVarSet $
2034 mapUnionFV injectiveVarsOfBinder dropped_binders
2035
2036 in not (subVarSet result_vars dropped_vars)
2037
2038 ------------------------------
2039 reifyName :: NamedThing n => n -> TH.Name
2040 reifyName thing
2041 | isExternalName name = mk_varg pkg_str mod_str occ_str
2042 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
2043 -- Many of the things we reify have local bindings, and
2044 -- NameL's aren't supposed to appear in binding positions, so
2045 -- we use NameU. When/if we start to reify nested things, that
2046 -- have free variables, we may need to generate NameL's for them.
2047 where
2048 name = getName thing
2049 mod = ASSERT( isExternalName name ) nameModule name
2050 pkg_str = unitIdString (moduleUnitId mod)
2051 mod_str = moduleNameString (moduleName mod)
2052 occ_str = occNameString occ
2053 occ = nameOccName name
2054 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
2055 | OccName.isVarOcc occ = TH.mkNameG_v
2056 | OccName.isTcOcc occ = TH.mkNameG_tc
2057 | otherwise = pprPanic "reifyName" (ppr name)
2058
2059 -- See Note [Reifying field labels]
2060 reifyFieldLabel :: FieldLabel -> TH.Name
2061 reifyFieldLabel fl
2062 | flIsOverloaded fl
2063 = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))
2064 | otherwise = TH.mkNameG_v pkg_str mod_str occ_str
2065 where
2066 name = flSelector fl
2067 mod = ASSERT( isExternalName name ) nameModule name
2068 pkg_str = unitIdString (moduleUnitId mod)
2069 mod_str = moduleNameString (moduleName mod)
2070 occ_str = unpackFS (flLabel fl)
2071
2072 reifySelector :: Id -> TyCon -> TH.Name
2073 reifySelector id tc
2074 = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of
2075 Just fl -> reifyFieldLabel fl
2076 Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
2077
2078 ------------------------------
2079 reifyFixity :: Name -> TcM (Maybe TH.Fixity)
2080 reifyFixity name
2081 = do { (found, fix) <- lookupFixityRn_help name
2082 ; return (if found then Just (conv_fix fix) else Nothing) }
2083 where
2084 conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d)
2085 conv_dir BasicTypes.InfixR = TH.InfixR
2086 conv_dir BasicTypes.InfixL = TH.InfixL
2087 conv_dir BasicTypes.InfixN = TH.InfixN
2088
2089 reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness
2090 reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness
2091 reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack
2092 reifyUnpackedness SrcUnpack = TH.SourceUnpack
2093
2094 reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness
2095 reifyStrictness NoSrcStrict = TH.NoSourceStrictness
2096 reifyStrictness SrcStrict = TH.SourceStrict
2097 reifyStrictness SrcLazy = TH.SourceLazy
2098
2099 reifySourceBang :: DataCon.HsSrcBang
2100 -> (TH.SourceUnpackedness, TH.SourceStrictness)
2101 reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)
2102
2103 reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness
2104 reifyDecidedStrictness HsLazy = TH.DecidedLazy
2105 reifyDecidedStrictness HsStrict = TH.DecidedStrict
2106 reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack
2107
2108 ------------------------------
2109 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
2110 lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
2111 lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
2112 = return $ ModuleTarget $
2113 mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
2114
2115 reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
2116 reifyAnnotations th_name
2117 = do { name <- lookupThAnnLookup th_name
2118 ; topEnv <- getTopEnv
2119 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
2120 ; tcg <- getGblEnv
2121 ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
2122 ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
2123 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
2124
2125 ------------------------------
2126 modToTHMod :: Module -> TH.Module
2127 modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m)
2128 (TH.ModName $ moduleNameString $ moduleName m)
2129
2130 reifyModule :: TH.Module -> TcM TH.ModuleInfo
2131 reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
2132 this_mod <- getModule
2133 let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)
2134 if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
2135 where
2136 reifyThisModule = do
2137 usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
2138 return $ TH.ModuleInfo usages
2139
2140 reifyFromIface reifMod = do
2141 iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod
2142 let usages = [modToTHMod m | usage <- mi_usages iface,
2143 Just m <- [usageToModule (moduleUnitId reifMod) usage] ]
2144 return $ TH.ModuleInfo usages
2145
2146 usageToModule :: UnitId -> Usage -> Maybe Module
2147 usageToModule _ (UsageFile {}) = Nothing
2148 usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
2149 usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
2150 usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m
2151
2152 ------------------------------
2153 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
2154 mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys
2155
2156 noTH :: PtrString -> SDoc -> TcM a
2157 noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+>
2158 text "in Template Haskell:",
2159 nest 2 d])
2160
2161 ppr_th :: TH.Ppr a => a -> SDoc
2162 ppr_th x = text (TH.pprint x)
2163
2164 {-
2165 Note [Reifying field labels]
2166 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2167 When reifying a datatype declared with DuplicateRecordFields enabled, we want
2168 the reified names of the fields to be labels rather than selector functions.
2169 That is, we want (reify ''T) and (reify 'foo) to produce
2170
2171 data T = MkT { foo :: Int }
2172 foo :: T -> Int
2173
2174 rather than
2175
2176 data T = MkT { $sel:foo:MkT :: Int }
2177 $sel:foo:MkT :: T -> Int
2178
2179 because otherwise TH code that uses the field names as strings will silently do
2180 the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather
2181 than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the
2182 environment, NameG can't be used to represent such fields. Instead,
2183 reifyFieldLabel uses NameQ.
2184
2185 However, this means that extracting the field name from the output of reify, and
2186 trying to reify it again, may fail with an ambiguity error if there are multiple
2187 such fields defined in the module (see the test case
2188 overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to
2189 the TH AST to make it able to represent duplicate record fields.
2190 -}