Error eagerly after renaming failures in reifyInstances
[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 RnSplice( traceSplice, SpliceInfo(..) )
56 import RdrName
57 import HscTypes
58 import Convert
59 import RnExpr
60 import RnEnv
61 import RnUtils ( HsDocContext(..) )
62 import RnFixity ( lookupFixityRn_help )
63 import RnTypes
64 import TcHsSyn
65 import TcSimplify
66 import Type
67 import Kind
68 import NameSet
69 import TcMType
70 import TcHsType
71 import TcIface
72 import TyCoRep
73 import FamInst
74 import FamInstEnv
75 import InstEnv
76 import Inst
77 import NameEnv
78 import PrelNames
79 import TysWiredIn
80 import OccName
81 import Hooks
82 import Var
83 import Module
84 import LoadIface
85 import Class
86 import TyCon
87 import CoAxiom
88 import PatSyn
89 import ConLike
90 import DataCon
91 import TcEvidence( TcEvBinds(..) )
92 import Id
93 import IdInfo
94 import DsExpr
95 import DsMonad
96 import GHC.Serialized
97 import ErrUtils
98 import Util
99 import Unique
100 import VarSet ( isEmptyVarSet, filterVarSet, mkVarSet, elemVarSet )
101 import Data.List ( find )
102 import Data.Maybe
103 import FastString
104 import BasicTypes hiding( SuccessFlag(..) )
105 import Maybes( MaybeErr(..) )
106 import DynFlags
107 import Panic
108 import Lexeme
109 import qualified EnumSet
110
111 import qualified Language.Haskell.TH as TH
112 -- THSyntax gives access to internal functions and data types
113 import qualified Language.Haskell.TH.Syntax as TH
114
115 -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
116 import GHC.Desugar ( AnnotationWrapper(..) )
117
118 import Control.Exception
119 import Data.Binary
120 import Data.Binary.Get
121 import qualified Data.ByteString as B
122 import qualified Data.ByteString.Lazy as LB
123 import Data.Dynamic ( fromDynamic, toDyn )
124 import qualified Data.Map as Map
125 import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )
126 import Data.Data (Data)
127 import Data.Proxy ( Proxy (..) )
128 import GHC.Exts ( unsafeCoerce# )
129
130 {-
131 ************************************************************************
132 * *
133 \subsection{Main interface + stubs for the non-GHCI case
134 * *
135 ************************************************************************
136 -}
137
138 tcTypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
139 tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType
140 -> TcM (HsExpr GhcTcId)
141 tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
142 -- None of these functions add constraints to the LIE
143
144 -- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
145 -- runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName)
146 -- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)
147 -- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
148
149 runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
150 {-
151 ************************************************************************
152 * *
153 \subsection{Quoting an expression}
154 * *
155 ************************************************************************
156 -}
157
158 -- See Note [How brackets and nested splices are handled]
159 -- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
160 tcTypedBracket rn_expr brack@(TExpBr expr) res_ty
161 = addErrCtxt (quotationCtxtDoc brack) $
162 do { cur_stage <- getStage
163 ; ps_ref <- newMutVar []
164 ; lie_var <- getConstraintVar -- Any constraints arising from nested splices
165 -- should get thrown into the constraint set
166 -- from outside the bracket
167
168 -- Typecheck expr to make sure it is valid,
169 -- Throw away the typechecked expression but return its type.
170 -- We'll typecheck it again when we splice it in somewhere
171 ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
172 tcInferRhoNC expr
173 -- NC for no context; tcBracket does that
174
175 ; meta_ty <- tcTExpTy expr_ty
176 ; ps' <- readMutVar ps_ref
177 ; texpco <- tcLookupId unsafeTExpCoerceName
178 ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
179 rn_expr
180 (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
181 (noLoc (HsTcBracketOut brack ps'))))
182 meta_ty res_ty }
183 tcTypedBracket _ other_brack _
184 = pprPanic "tcTypedBracket" (ppr other_brack)
185
186 -- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)
187 tcUntypedBracket rn_expr brack ps res_ty
188 = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
189 ; ps' <- mapM tcPendingSplice ps
190 ; meta_ty <- tcBrackTy brack
191 ; traceTc "tc_bracket done untyped" (ppr meta_ty)
192 ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")
193 rn_expr (HsTcBracketOut brack ps') meta_ty res_ty }
194
195 ---------------
196 tcBrackTy :: HsBracket GhcRn -> TcM TcType
197 tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
198 tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp)
199 tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
200 tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
201 tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)
202 tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL"
203 tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr"
204
205 ---------------
206 tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
207 tcPendingSplice (PendingRnSplice flavour splice_name expr)
208 = do { res_ty <- tcMetaTy meta_ty_name
209 ; expr' <- tcMonoExpr expr (mkCheckExpType res_ty)
210 ; return (PendingTcSplice splice_name expr') }
211 where
212 meta_ty_name = case flavour of
213 UntypedExpSplice -> expQTyConName
214 UntypedPatSplice -> patQTyConName
215 UntypedTypeSplice -> typeQTyConName
216 UntypedDeclSplice -> decsQTyConName
217
218 ---------------
219 -- Takes a tau and returns the type Q (TExp tau)
220 tcTExpTy :: TcType -> TcM TcType
221 tcTExpTy exp_ty
222 = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)
223 ; q <- tcLookupTyCon qTyConName
224 ; texp <- tcLookupTyCon tExpTyConName
225 ; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) }
226 where
227 err_msg ty
228 = vcat [ text "Illegal polytype:" <+> ppr ty
229 , text "The type of a Typed Template Haskell expression must" <+>
230 text "not have any quantification." ]
231
232 quotationCtxtDoc :: HsBracket GhcRn -> SDoc
233 quotationCtxtDoc br_body
234 = hang (text "In the Template Haskell quotation")
235 2 (ppr br_body)
236
237
238 -- The whole of the rest of the file is the else-branch (ie stage2 only)
239
240 {-
241 Note [How top-level splices are handled]
242 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
243 Top-level splices (those not inside a [| .. |] quotation bracket) are handled
244 very straightforwardly:
245
246 1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
247
248 2. runMetaT: desugar, compile, run it, and convert result back to
249 HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,
250 HsExpr RdrName etc)
251
252 3. treat the result as if that's what you saw in the first place
253 e.g for HsType, rename and kind-check
254 for HsExpr, rename and type-check
255
256 (The last step is different for decls, because they can *only* be
257 top-level: we return the result of step 2.)
258
259 Note [How brackets and nested splices are handled]
260 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
261 Nested splices (those inside a [| .. |] quotation bracket),
262 are treated quite differently.
263
264 Remember, there are two forms of bracket
265 typed [|| e ||]
266 and untyped [| e |]
267
268 The life cycle of a typed bracket:
269 * Starts as HsBracket
270
271 * When renaming:
272 * Set the ThStage to (Brack s RnPendingTyped)
273 * Rename the body
274 * Result is still a HsBracket
275
276 * When typechecking:
277 * Set the ThStage to (Brack s (TcPending ps_var lie_var))
278 * Typecheck the body, and throw away the elaborated result
279 * Nested splices (which must be typed) are typechecked, and
280 the results accumulated in ps_var; their constraints
281 accumulate in lie_var
282 * Result is a HsTcBracketOut rn_brack pending_splices
283 where rn_brack is the incoming renamed bracket
284
285 The life cycle of a un-typed bracket:
286 * Starts as HsBracket
287
288 * When renaming:
289 * Set the ThStage to (Brack s (RnPendingUntyped ps_var))
290 * Rename the body
291 * Nested splices (which must be untyped) are renamed, and the
292 results accumulated in ps_var
293 * Result is still (HsRnBracketOut rn_body pending_splices)
294
295 * When typechecking a HsRnBracketOut
296 * Typecheck the pending_splices individually
297 * Ignore the body of the bracket; just check that the context
298 expects a bracket of that type (e.g. a [p| pat |] bracket should
299 be in a context needing a (Q Pat)
300 * Result is a HsTcBracketOut rn_brack pending_splices
301 where rn_brack is the incoming renamed bracket
302
303
304 In both cases, desugaring happens like this:
305 * HsTcBracketOut is desugared by DsMeta.dsBracket. It
306
307 a) Extends the ds_meta environment with the PendingSplices
308 attached to the bracket
309
310 b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
311 run, will produce a suitable TH expression/type/decl. This
312 is why we leave the *renamed* expression attached to the bracket:
313 the quoted expression should not be decorated with all the goop
314 added by the type checker
315
316 * Each splice carries a unique Name, called a "splice point", thus
317 ${n}(e). The name is initialised to an (Unqual "splice") when the
318 splice is created; the renamer gives it a unique.
319
320 * When DsMeta (used to desugar the body of the bracket) comes across
321 a splice, it looks up the splice's Name, n, in the ds_meta envt,
322 to find an (HsExpr Id) that should be substituted for the splice;
323 it just desugars it to get a CoreExpr (DsMeta.repSplice).
324
325 Example:
326 Source: f = [| Just $(g 3) |]
327 The [| |] part is a HsBracket
328
329 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
330 The [| |] part is a HsBracketOut, containing *renamed*
331 (not typechecked) expression
332 The "s7" is the "splice point"; the (g Int 3) part
333 is a typechecked expression
334
335 Desugared: f = do { s7 <- g Int 3
336 ; return (ConE "Data.Maybe.Just" s7) }
337
338
339 Note [Template Haskell state diagram]
340 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
341 Here are the ThStages, s, their corresponding level numbers
342 (the result of (thLevel s)), and their state transitions.
343 The top level of the program is stage Comp:
344
345 Start here
346 |
347 V
348 ----------- $ ------------ $
349 | Comp | ---------> | Splice | -----|
350 | 1 | | 0 | <----|
351 ----------- ------------
352 ^ | ^ |
353 $ | | [||] $ | | [||]
354 | v | v
355 -------------- ----------------
356 | Brack Comp | | Brack Splice |
357 | 2 | | 1 |
358 -------------- ----------------
359
360 * Normal top-level declarations start in state Comp
361 (which has level 1).
362 Annotations start in state Splice, since they are
363 treated very like a splice (only without a '$')
364
365 * Code compiled in state Splice (and only such code)
366 will be *run at compile time*, with the result replacing
367 the splice
368
369 * The original paper used level -1 instead of 0, etc.
370
371 * The original paper did not allow a splice within a
372 splice, but there is no reason not to. This is the
373 $ transition in the top right.
374
375 Note [Template Haskell levels]
376 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
377 * Imported things are impLevel (= 0)
378
379 * However things at level 0 are not *necessarily* imported.
380 eg $( \b -> ... ) here b is bound at level 0
381
382 * In GHCi, variables bound by a previous command are treated
383 as impLevel, because we have bytecode for them.
384
385 * Variables are bound at the "current level"
386
387 * The current level starts off at outerLevel (= 1)
388
389 * The level is decremented by splicing $(..)
390 incremented by brackets [| |]
391 incremented by name-quoting 'f
392
393 When a variable is used, we compare
394 bind: binding level, and
395 use: current level at usage site
396
397 Generally
398 bind > use Always error (bound later than used)
399 [| \x -> $(f x) |]
400
401 bind = use Always OK (bound same stage as used)
402 [| \x -> $(f [| x |]) |]
403
404 bind < use Inside brackets, it depends
405 Inside splice, OK
406 Inside neither, OK
407
408 For (bind < use) inside brackets, there are three cases:
409 - Imported things OK f = [| map |]
410 - Top-level things OK g = [| f |]
411 - Non-top-level Only if there is a liftable instance
412 h = \(x:Int) -> [| x |]
413
414 To track top-level-ness we use the ThBindEnv in TcLclEnv
415
416 For example:
417 f = ...
418 g1 = $(map ...) is OK
419 g2 = $(f ...) is not OK; because we havn't compiled f yet
420
421 -}
422
423 {-
424 ************************************************************************
425 * *
426 \subsection{Splicing an expression}
427 * *
428 ************************************************************************
429 -}
430
431 tcSpliceExpr splice@(HsTypedSplice _ name expr) res_ty
432 = addErrCtxt (spliceCtxtDoc splice) $
433 setSrcSpan (getLoc expr) $ do
434 { stage <- getStage
435 ; case stage of
436 Splice {} -> tcTopSplice expr res_ty
437 Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty
438 RunSplice _ ->
439 -- See Note [RunSplice ThLevel] in "TcRnTypes".
440 pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++
441 "running another splice") (ppr splice)
442 Comp -> tcTopSplice expr res_ty
443 }
444 tcSpliceExpr splice _
445 = pprPanic "tcSpliceExpr" (ppr splice)
446
447 {- Note [Collecting modFinalizers in typed splices]
448 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
449
450 'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local
451 environment (see Note [Delaying modFinalizers in untyped splices] in
452 "RnSplice"). Thus after executing the splice, we move the finalizers to the
453 finalizer list in the global environment and set them to use the current local
454 environment (with 'addModFinalizersWithLclEnv').
455
456 -}
457
458 tcNestedSplice :: ThStage -> PendingStuff -> Name
459 -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
460 -- See Note [How brackets and nested splices are handled]
461 -- A splice inside brackets
462 tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty
463 = do { res_ty <- expTypeToType res_ty
464 ; meta_exp_ty <- tcTExpTy res_ty
465 ; expr' <- setStage pop_stage $
466 setConstraintVar lie_var $
467 tcMonoExpr expr (mkCheckExpType meta_exp_ty)
468 ; untypeq <- tcLookupId unTypeQName
469 ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'
470 ; ps <- readMutVar ps_var
471 ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
472
473 -- The returned expression is ignored; it's in the pending splices
474 ; return (panic "tcSpliceExpr") }
475
476 tcNestedSplice _ _ splice_name _ _
477 = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)
478
479 tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
480 tcTopSplice expr res_ty
481 = do { -- Typecheck the expression,
482 -- making sure it has type Q (T res_ty)
483 res_ty <- expTypeToType res_ty
484 ; meta_exp_ty <- tcTExpTy res_ty
485 ; zonked_q_expr <- tcTopSpliceExpr Typed $
486 tcMonoExpr expr (mkCheckExpType meta_exp_ty)
487
488 -- See Note [Collecting modFinalizers in typed splices].
489 ; modfinalizers_ref <- newTcRef []
490 -- Run the expression
491 ; expr2 <- setStage (RunSplice modfinalizers_ref) $
492 runMetaE zonked_q_expr
493 ; mod_finalizers <- readTcRef modfinalizers_ref
494 ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
495 ; traceSplice (SpliceInfo { spliceDescription = "expression"
496 , spliceIsDecl = False
497 , spliceSource = Just expr
498 , spliceGenerated = ppr expr2 })
499
500 -- Rename and typecheck the spliced-in expression,
501 -- making sure it has type res_ty
502 -- These steps should never fail; this is a *typed* splice
503 ; addErrCtxt (spliceResultDoc expr) $ do
504 { (exp3, _fvs) <- rnLExpr expr2
505 ; exp4 <- tcMonoExpr exp3 (mkCheckExpType res_ty)
506 ; return (unLoc exp4) } }
507
508 {-
509 ************************************************************************
510 * *
511 \subsection{Error messages}
512 * *
513 ************************************************************************
514 -}
515
516 spliceCtxtDoc :: HsSplice GhcRn -> SDoc
517 spliceCtxtDoc splice
518 = hang (text "In the Template Haskell splice")
519 2 (pprSplice splice)
520
521 spliceResultDoc :: LHsExpr GhcRn -> SDoc
522 spliceResultDoc expr
523 = sep [ text "In the result of the splice:"
524 , nest 2 (char '$' <> ppr expr)
525 , text "To see what the splice expanded to, use -ddump-splices"]
526
527 -------------------
528 tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
529 -- Note [How top-level splices are handled]
530 -- Type check an expression that is the body of a top-level splice
531 -- (the caller will compile and run it)
532 -- Note that set the level to Splice, regardless of the original level,
533 -- before typechecking the expression. For example:
534 -- f x = $( ...$(g 3) ... )
535 -- The recursive call to tcPolyExpr will simply expand the
536 -- inner escape before dealing with the outer one
537
538 tcTopSpliceExpr isTypedSplice tc_action
539 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
540 -- if the type checker fails!
541 unsetGOptM Opt_DeferTypeErrors $
542 -- Don't defer type errors. Not only are we
543 -- going to run this code, but we do an unsafe
544 -- coerce, so we get a seg-fault if, say we
545 -- splice a type into a place where an expression
546 -- is expected (Trac #7276)
547 setStage (Splice isTypedSplice) $
548 do { -- Typecheck the expression
549 (expr', wanted) <- captureConstraints tc_action
550 ; const_binds <- simplifyTop wanted
551
552 -- Zonk it and tie the knot of dictionary bindings
553 ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') }
554
555 {-
556 ************************************************************************
557 * *
558 Annotations
559 * *
560 ************************************************************************
561 -}
562
563 runAnnotation target expr = do
564 -- Find the classes we want instances for in order to call toAnnotationWrapper
565 loc <- getSrcSpanM
566 data_class <- tcLookupClass dataClassName
567 to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
568
569 -- Check the instances we require live in another module (we want to execute it..)
570 -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
571 -- also resolves the LIE constraints to detect e.g. instance ambiguity
572 zonked_wrapped_expr' <- tcTopSpliceExpr Untyped $
573 do { (expr', expr_ty) <- tcInferRhoNC expr
574 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
575 -- By instantiating the call >here< it gets registered in the
576 -- LIE consulted by tcTopSpliceExpr
577 -- and hence ensures the appropriate dictionary is bound by const_binds
578 ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
579 ; let specialised_to_annotation_wrapper_expr
580 = L loc (mkHsWrap wrapper
581 (HsVar (L loc to_annotation_wrapper_id)))
582 ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
583
584 -- Run the appropriately wrapped expression to get the value of
585 -- the annotation and its dictionaries. The return value is of
586 -- type AnnotationWrapper by construction, so this conversion is
587 -- safe
588 serialized <- runMetaAW zonked_wrapped_expr'
589 return Annotation {
590 ann_target = target,
591 ann_value = serialized
592 }
593
594 convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)
595 convertAnnotationWrapper fhv = do
596 dflags <- getDynFlags
597 if gopt Opt_ExternalInterpreter dflags
598 then do
599 Right <$> runTH THAnnWrapper fhv
600 else do
601 annotation_wrapper <- liftIO $ wormhole dflags fhv
602 return $ Right $
603 case unsafeCoerce# annotation_wrapper of
604 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
605 -- Got the value and dictionaries: build the serialized value and
606 -- call it a day. We ensure that we seq the entire serialized value
607 -- in order that any errors in the user-written code for the
608 -- annotation are exposed at this point. This is also why we are
609 -- doing all this stuff inside the context of runMeta: it has the
610 -- facilities to deal with user error in a meta-level expression
611 seqSerialized serialized `seq` serialized
612
613 -- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
614 seqSerialized :: Serialized -> ()
615 seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
616
617
618 {-
619 ************************************************************************
620 * *
621 \subsection{Running an expression}
622 * *
623 ************************************************************************
624 -}
625
626 runQuasi :: TH.Q a -> TcM a
627 runQuasi act = TH.runQ act
628
629 runRemoteModFinalizers :: ThModFinalizers -> TcM ()
630 runRemoteModFinalizers (ThModFinalizers finRefs) = do
631 dflags <- getDynFlags
632 let withForeignRefs [] f = f []
633 withForeignRefs (x : xs) f = withForeignRef x $ \r ->
634 withForeignRefs xs $ \rs -> f (r : rs)
635 if gopt Opt_ExternalInterpreter dflags then do
636 hsc_env <- env_top <$> getEnv
637 withIServ hsc_env $ \i -> do
638 tcg <- getGblEnv
639 th_state <- readTcRef (tcg_th_remote_state tcg)
640 case th_state of
641 Nothing -> return () -- TH was not started, nothing to do
642 Just fhv -> do
643 liftIO $ withForeignRef fhv $ \st ->
644 withForeignRefs finRefs $ \qrefs ->
645 writeIServ i (putMessage (RunModFinalizers st qrefs))
646 () <- runRemoteTH i []
647 readQResult i
648 else do
649 qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
650 runQuasi $ sequence_ qs
651
652 runQResult
653 :: (a -> String)
654 -> (SrcSpan -> a -> b)
655 -> (ForeignHValue -> TcM a)
656 -> SrcSpan
657 -> ForeignHValue {- TH.Q a -}
658 -> TcM b
659 runQResult show_th f runQ expr_span hval
660 = do { th_result <- runQ hval
661 ; traceTc "Got TH result:" (text (show_th th_result))
662 ; return (f expr_span th_result) }
663
664
665 -----------------
666 runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn)
667 -> LHsExpr GhcTc
668 -> TcM hs_syn
669 runMeta unwrap e
670 = do { h <- getHooked runMetaHook defaultRunMeta
671 ; unwrap h e }
672
673 defaultRunMeta :: MetaHook TcM
674 defaultRunMeta (MetaE r)
675 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)
676 defaultRunMeta (MetaP r)
677 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)
678 defaultRunMeta (MetaT r)
679 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)
680 defaultRunMeta (MetaD r)
681 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)
682 defaultRunMeta (MetaAW r)
683 = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)
684 -- We turn off showing the code in meta-level exceptions because doing so exposes
685 -- the toAnnotationWrapper function that we slap around the user's code
686
687 ----------------
688 runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper
689 -> TcM Serialized
690 runMetaAW = runMeta metaRequestAW
691
692 runMetaE :: LHsExpr GhcTc -- Of type (Q Exp)
693 -> TcM (LHsExpr GhcPs)
694 runMetaE = runMeta metaRequestE
695
696 runMetaP :: LHsExpr GhcTc -- Of type (Q Pat)
697 -> TcM (LPat GhcPs)
698 runMetaP = runMeta metaRequestP
699
700 runMetaT :: LHsExpr GhcTc -- Of type (Q Type)
701 -> TcM (LHsType GhcPs)
702 runMetaT = runMeta metaRequestT
703
704 runMetaD :: LHsExpr GhcTc -- Of type Q [Dec]
705 -> TcM [LHsDecl GhcPs]
706 runMetaD = runMeta metaRequestD
707
708 ---------------
709 runMeta' :: Bool -- Whether code should be printed in the exception message
710 -> (hs_syn -> SDoc) -- how to print the code
711 -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x
712 -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or
713 -- something like that
714 -> TcM hs_syn -- Of type t
715 runMeta' show_code ppr_hs run_and_convert expr
716 = do { traceTc "About to run" (ppr expr)
717 ; recordThSpliceUse -- seems to be the best place to do this,
718 -- we catch all kinds of splices and annotations.
719
720 -- Check that we've had no errors of any sort so far.
721 -- For example, if we found an error in an earlier defn f, but
722 -- recovered giving it type f :: forall a.a, it'd be very dodgy
723 -- to carry ont. Mind you, the staging restrictions mean we won't
724 -- actually run f, but it still seems wrong. And, more concretely,
725 -- see Trac #5358 for an example that fell over when trying to
726 -- reify a function with a "?" kind in it. (These don't occur
727 -- in type-correct programs.
728 ; failIfErrsM
729
730 -- Desugar
731 ; ds_expr <- initDsTc (dsLExpr expr)
732 -- Compile and link it; might fail if linking fails
733 ; hsc_env <- getTopEnv
734 ; src_span <- getSrcSpanM
735 ; traceTc "About to run (desugared)" (ppr ds_expr)
736 ; either_hval <- tryM $ liftIO $
737 HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
738 ; case either_hval of {
739 Left exn -> fail_with_exn "compile and link" exn ;
740 Right hval -> do
741
742 { -- Coerce it to Q t, and run it
743
744 -- Running might fail if it throws an exception of any kind (hence tryAllM)
745 -- including, say, a pattern-match exception in the code we are running
746 --
747 -- We also do the TH -> HS syntax conversion inside the same
748 -- exception-cacthing thing so that if there are any lurking
749 -- exceptions in the data structure returned by hval, we'll
750 -- encounter them inside the try
751 --
752 -- See Note [Exceptions in TH]
753 let expr_span = getLoc expr
754 ; either_tval <- tryAllM $
755 setSrcSpan expr_span $ -- Set the span so that qLocation can
756 -- see where this splice is
757 do { mb_result <- run_and_convert expr_span hval
758 ; case mb_result of
759 Left err -> failWithTc err
760 Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
761 ; return $! result } }
762
763 ; case either_tval of
764 Right v -> return v
765 Left se -> case fromException se of
766 Just IOEnvFailure -> failM -- Error already in Tc monad
767 _ -> fail_with_exn "run" se -- Exception
768 }}}
769 where
770 -- see Note [Concealed TH exceptions]
771 fail_with_exn :: Exception e => String -> e -> TcM a
772 fail_with_exn phase exn = do
773 exn_msg <- liftIO $ Panic.safeShowException exn
774 let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
775 nest 2 (text exn_msg),
776 if show_code then text "Code:" <+> ppr expr else empty]
777 failWithTc msg
778
779 {-
780 Note [Exceptions in TH]
781 ~~~~~~~~~~~~~~~~~~~~~~~
782 Suppose we have something like this
783 $( f 4 )
784 where
785 f :: Int -> Q [Dec]
786 f n | n>3 = fail "Too many declarations"
787 | otherwise = ...
788
789 The 'fail' is a user-generated failure, and should be displayed as a
790 perfectly ordinary compiler error message, not a panic or anything
791 like that. Here's how it's processed:
792
793 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
794 effectively transforms (fail s) to
795 qReport True s >> fail
796 where 'qReport' comes from the Quasi class and fail from its monad
797 superclass.
798
799 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
800 (qReport True s) by using addErr to add an error message to the bag of errors.
801 The 'fail' in TcM raises an IOEnvFailure exception
802
803 * 'qReport' forces the message to ensure any exception hidden in unevaluated
804 thunk doesn't get into the bag of errors. Otherwise the following splice
805 will triger panic (Trac #8987):
806 $(fail undefined)
807 See also Note [Concealed TH exceptions]
808
809 * So, when running a splice, we catch all exceptions; then for
810 - an IOEnvFailure exception, we assume the error is already
811 in the error-bag (above)
812 - other errors, we add an error to the bag
813 and then fail
814
815 Note [Concealed TH exceptions]
816 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
817 When displaying the error message contained in an exception originated from TH
818 code, we need to make sure that the error message itself does not contain an
819 exception. For example, when executing the following splice:
820
821 $( error ("foo " ++ error "bar") )
822
823 the message for the outer exception is a thunk which will throw the inner
824 exception when evaluated.
825
826 For this reason, we display the message of a TH exception using the
827 'safeShowException' function, which recursively catches any exception thrown
828 when showing an error message.
829
830
831 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
832 -}
833
834 instance TH.Quasi TcM where
835 qNewName s = do { u <- newUnique
836 ; let i = getKey u
837 ; return (TH.mkNameU s i) }
838
839 -- 'msg' is forced to ensure exceptions don't escape,
840 -- see Note [Exceptions in TH]
841 qReport True msg = seqList msg $ addErr (text msg)
842 qReport False msg = seqList msg $ addWarn NoReason (text msg)
843
844 qLocation = do { m <- getModule
845 ; l <- getSrcSpanM
846 ; r <- case l of
847 UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
848 (ppr l)
849 RealSrcSpan s -> return s
850 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
851 , TH.loc_module = moduleNameString (moduleName m)
852 , TH.loc_package = unitIdString (moduleUnitId m)
853 , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
854 , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
855
856 qLookupName = lookupName
857 qReify = reify
858 qReifyFixity nm = lookupThName nm >>= reifyFixity
859 qReifyInstances = reifyInstances
860 qReifyRoles = reifyRoles
861 qReifyAnnotations = reifyAnnotations
862 qReifyModule = reifyModule
863 qReifyConStrictness nm = do { nm' <- lookupThName nm
864 ; dc <- tcLookupDataCon nm'
865 ; let bangs = dataConImplBangs dc
866 ; return (map reifyDecidedStrictness bangs) }
867
868 -- For qRecover, discard error messages if
869 -- the recovery action is chosen. Otherwise
870 -- we'll only fail higher up.
871 qRecover recover main = tryTcDiscardingErrs recover main
872 qRunIO io = liftIO io
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 = familyTyConInjectivityInfo 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@(ForAllTy {}) = reify_for_all ty
1679 reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) }
1680 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1681 reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
1682 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1683 reifyType ty@(FunTy t1 t2)
1684 | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
1685 | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1686 reifyType ty@(CastTy {}) = noTH (sLit "kind casts") (ppr ty)
1687 reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)
1688
1689 reify_for_all :: TyCoRep.Type -> TcM TH.Type
1690 reify_for_all ty
1691 = do { cxt' <- reifyCxt cxt;
1692 ; tau' <- reifyType tau
1693 ; tvs' <- reifyTyVars tvs Nothing
1694 ; return (TH.ForallT tvs' cxt' tau') }
1695 where
1696 (tvs, cxt, tau) = tcSplitSigmaTy ty
1697
1698 reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
1699 reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
1700 reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
1701
1702 reifyTypes :: [Type] -> TcM [TH.Type]
1703 reifyTypes = mapM reifyType
1704
1705 reifyPatSynType
1706 :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type
1707 -- reifies a pattern synonym's type and returns its *complete* type
1708 -- signature; see NOTE [Pattern synonym signatures and Template
1709 -- Haskell]
1710 reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
1711 = do { univTyVars' <- reifyTyVars univTyVars Nothing
1712 ; req' <- reifyCxt req
1713 ; exTyVars' <- reifyTyVars exTyVars Nothing
1714 ; prov' <- reifyCxt prov
1715 ; tau' <- reifyType (mkFunTys argTys resTy)
1716 ; return $ TH.ForallT univTyVars' req'
1717 $ TH.ForallT exTyVars' prov' tau' }
1718
1719 reifyKind :: Kind -> TcM TH.Kind
1720 reifyKind ki
1721 = do { let (kis, ki') = splitFunTys ki
1722 ; ki'_rep <- reifyNonArrowKind ki'
1723 ; kis_rep <- mapM reifyKind kis
1724 ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) }
1725 where
1726 reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT
1727 | isConstraintKind k = return TH.ConstraintT
1728 reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v))
1729 reifyNonArrowKind (FunTy _ k) = reifyKind k
1730 reifyNonArrowKind (ForAllTy _ k) = reifyKind k
1731 reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis
1732 reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1
1733 ; k2' <- reifyKind k2
1734 ; return (TH.AppT k1' k2')
1735 }
1736 reifyNonArrowKind k = noTH (sLit "this kind") (ppr k)
1737
1738 reify_kc_app :: TyCon -> [TyCoRep.Kind] -> TcM TH.Kind
1739 reify_kc_app kc kis
1740 = fmap (mkThAppTs r_kc) (mapM reifyKind vis_kis)
1741 where
1742 r_kc | isTupleTyCon kc = TH.TupleT (tyConArity kc)
1743 | kc `hasKey` listTyConKey = TH.ListT
1744 | otherwise = TH.ConT (reifyName kc)
1745
1746 vis_kis = filterOutInvisibleTypes kc kis
1747
1748 reifyCxt :: [PredType] -> TcM [TH.Pred]
1749 reifyCxt = mapM reifyPred
1750
1751 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1752 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1753
1754 reifyTyVars :: [TyVar]
1755 -> Maybe TyCon -- the tycon if the tycovars are from a tycon.
1756 -- Used to detect which tvs are implicit.
1757 -> TcM [TH.TyVarBndr]
1758 reifyTyVars tvs m_tc = mapM reify_tv tvs'
1759 where
1760 tvs' = case m_tc of
1761 Just tc -> filterOutInvisibleTyVars tc tvs
1762 Nothing -> tvs
1763
1764 -- even if the kind is *, we need to include a kind annotation,
1765 -- in case a poly-kind would be inferred without the annotation.
1766 -- See #8953 or test th/T8953
1767 reify_tv tv = TH.KindedTV name <$> reifyKind kind
1768 where
1769 kind = tyVarKind tv
1770 name = reifyName tv
1771
1772 {-
1773 Note [Kind annotations on TyConApps]
1774 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1775 A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.
1776 For example:
1777
1778 type family F a :: k
1779 type instance F Int = (Proxy :: * -> *)
1780 type instance F Bool = (Proxy :: (* -> *) -> *)
1781
1782 It's hard to figure out where these annotations should appear, so we do this:
1783 Suppose the tycon is applied to n arguments. We strip off the first n
1784 arguments of the tycon's kind. If there are any variables left in the result
1785 kind, we put on a kind annotation. But we must be slightly careful: it's
1786 possible that the tycon's kind will have fewer than n arguments, in the case
1787 that the concrete application instantiates a result kind variable with an
1788 arrow kind. So, if we run out of arguments, we conservatively put on a kind
1789 annotation anyway. This should be a rare case, indeed. Here is an example:
1790
1791 data T1 :: k1 -> k2 -> *
1792 data T2 :: k1 -> k2 -> *
1793
1794 type family G (a :: k) :: k
1795 type instance G T1 = T2
1796
1797 type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above
1798
1799 Here G's kind is (forall k. k -> k), and the desugared RHS of that last
1800 instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
1801 the algorithm above, there are 3 arguments to G so we should peel off 3
1802 arguments in G's kind. But G's kind has only two arguments. This is the
1803 rare special case, and we conservatively choose to put the annotation
1804 in.
1805
1806 See #8953 and test th/T8953.
1807 -}
1808
1809 reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
1810 reify_tc_app tc tys
1811 = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
1812 ; maybe_sig_t (mkThAppTs r_tc tys') }
1813 where
1814 arity = tyConArity tc
1815 tc_binders = tyConBinders tc
1816 tc_res_kind = tyConResKind tc
1817
1818 r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2)
1819 | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2)
1820 | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2)
1821 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1822 | isTupleTyCon tc = if isPromotedDataCon tc
1823 then TH.PromotedTupleT arity
1824 else TH.TupleT arity
1825 | tc `hasKey` listTyConKey = TH.ListT
1826 | tc `hasKey` nilDataConKey = TH.PromotedNilT
1827 | tc `hasKey` consDataConKey = TH.PromotedConsT
1828 | tc `hasKey` heqTyConKey = TH.EqualityT
1829 | tc `hasKey` eqPrimTyConKey = TH.EqualityT
1830 | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
1831 | isPromotedDataCon tc = TH.PromotedT (reifyName tc)
1832 | otherwise = TH.ConT (reifyName tc)
1833
1834 -- See Note [Kind annotations on TyConApps]
1835 maybe_sig_t th_type
1836 | needs_kind_sig
1837 = do { let full_kind = typeKind (mkTyConApp tc tys)
1838 ; th_full_kind <- reifyKind full_kind
1839 ; return (TH.SigT th_type th_full_kind) }
1840 | otherwise
1841 = return th_type
1842
1843 needs_kind_sig
1844 | GT <- compareLength tys tc_binders
1845 = tcIsTyVarTy tc_res_kind
1846 | otherwise
1847 = not . isEmptyVarSet $
1848 filterVarSet isTyVar $
1849 tyCoVarsOfType $
1850 mkTyConKind (dropList tys tc_binders) tc_res_kind
1851
1852 reifyPred :: TyCoRep.PredType -> TcM TH.Pred
1853 reifyPred ty
1854 -- We could reify the invisible parameter as a class but it seems
1855 -- nicer to support them properly...
1856 | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
1857 | otherwise = reifyType ty
1858
1859 ------------------------------
1860 reifyName :: NamedThing n => n -> TH.Name
1861 reifyName thing
1862 | isExternalName name = mk_varg pkg_str mod_str occ_str
1863 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1864 -- Many of the things we reify have local bindings, and
1865 -- NameL's aren't supposed to appear in binding positions, so
1866 -- we use NameU. When/if we start to reify nested things, that
1867 -- have free variables, we may need to generate NameL's for them.
1868 where
1869 name = getName thing
1870 mod = ASSERT( isExternalName name ) nameModule name
1871 pkg_str = unitIdString (moduleUnitId mod)
1872 mod_str = moduleNameString (moduleName mod)
1873 occ_str = occNameString occ
1874 occ = nameOccName name
1875 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1876 | OccName.isVarOcc occ = TH.mkNameG_v
1877 | OccName.isTcOcc occ = TH.mkNameG_tc
1878 | otherwise = pprPanic "reifyName" (ppr name)
1879
1880 -- See Note [Reifying field labels]
1881 reifyFieldLabel :: FieldLabel -> TH.Name
1882 reifyFieldLabel fl
1883 | flIsOverloaded fl
1884 = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))
1885 | otherwise = TH.mkNameG_v pkg_str mod_str occ_str
1886 where
1887 name = flSelector fl
1888 mod = ASSERT( isExternalName name ) nameModule name
1889 pkg_str = unitIdString (moduleUnitId mod)
1890 mod_str = moduleNameString (moduleName mod)
1891 occ_str = unpackFS (flLabel fl)
1892
1893 reifySelector :: Id -> TyCon -> TH.Name
1894 reifySelector id tc
1895 = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of
1896 Just fl -> reifyFieldLabel fl
1897 Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
1898
1899 ------------------------------
1900 reifyFixity :: Name -> TcM (Maybe TH.Fixity)
1901 reifyFixity name
1902 = do { (found, fix) <- lookupFixityRn_help name
1903 ; return (if found then Just (conv_fix fix) else Nothing) }
1904 where
1905 conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d)
1906 conv_dir BasicTypes.InfixR = TH.InfixR
1907 conv_dir BasicTypes.InfixL = TH.InfixL
1908 conv_dir BasicTypes.InfixN = TH.InfixN
1909
1910 reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness
1911 reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness
1912 reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack
1913 reifyUnpackedness SrcUnpack = TH.SourceUnpack
1914
1915 reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness
1916 reifyStrictness NoSrcStrict = TH.NoSourceStrictness
1917 reifyStrictness SrcStrict = TH.SourceStrict
1918 reifyStrictness SrcLazy = TH.SourceLazy
1919
1920 reifySourceBang :: DataCon.HsSrcBang
1921 -> (TH.SourceUnpackedness, TH.SourceStrictness)
1922 reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)
1923
1924 reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness
1925 reifyDecidedStrictness HsLazy = TH.DecidedLazy
1926 reifyDecidedStrictness HsStrict = TH.DecidedStrict
1927 reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack
1928
1929 ------------------------------
1930 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
1931 lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
1932 lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
1933 = return $ ModuleTarget $
1934 mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
1935
1936 reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
1937 reifyAnnotations th_name
1938 = do { name <- lookupThAnnLookup th_name
1939 ; topEnv <- getTopEnv
1940 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1941 ; tcg <- getGblEnv
1942 ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
1943 ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
1944 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1945
1946 ------------------------------
1947 modToTHMod :: Module -> TH.Module
1948 modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m)
1949 (TH.ModName $ moduleNameString $ moduleName m)
1950
1951 reifyModule :: TH.Module -> TcM TH.ModuleInfo
1952 reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
1953 this_mod <- getModule
1954 let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)
1955 if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
1956 where
1957 reifyThisModule = do
1958 usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
1959 return $ TH.ModuleInfo usages
1960
1961 reifyFromIface reifMod = do
1962 iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod
1963 let usages = [modToTHMod m | usage <- mi_usages iface,
1964 Just m <- [usageToModule (moduleUnitId reifMod) usage] ]
1965 return $ TH.ModuleInfo usages
1966
1967 usageToModule :: UnitId -> Usage -> Maybe Module
1968 usageToModule _ (UsageFile {}) = Nothing
1969 usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
1970 usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
1971 usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m
1972
1973 ------------------------------
1974 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
1975 mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys
1976
1977 noTH :: LitString -> SDoc -> TcM a
1978 noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+>
1979 text "in Template Haskell:",
1980 nest 2 d])
1981
1982 ppr_th :: TH.Ppr a => a -> SDoc
1983 ppr_th x = text (TH.pprint x)
1984
1985 {-
1986 Note [Reifying field labels]
1987 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1988 When reifying a datatype declared with DuplicateRecordFields enabled, we want
1989 the reified names of the fields to be labels rather than selector functions.
1990 That is, we want (reify ''T) and (reify 'foo) to produce
1991
1992 data T = MkT { foo :: Int }
1993 foo :: T -> Int
1994
1995 rather than
1996
1997 data T = MkT { $sel:foo:MkT :: Int }
1998 $sel:foo:MkT :: T -> Int
1999
2000 because otherwise TH code that uses the field names as strings will silently do
2001 the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather
2002 than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the
2003 environment, NameG can't be used to represent such fields. Instead,
2004 reifyFieldLabel uses NameQ.
2005
2006 However, this means that extracting the field name from the output of reify, and
2007 trying to reify it again, may fail with an ambiguity error if there are multiple
2008 such fields defined in the module (see the test case
2009 overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to
2010 the TH AST to make it able to represent duplicate record fields.
2011 -}