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