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