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