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