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