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