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