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