Revert "Refactor CallStack defaulting slightly"
[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 -- These functions are defined in stage1 and stage2
21 -- The raise civilised errors in stage1
22 tcSpliceExpr, tcTypedBracket, tcUntypedBracket,
23 -- runQuasiQuoteExpr, runQuasiQuotePat,
24 -- runQuasiQuoteDecl, runQuasiQuoteType,
25 runAnnotation,
26
27 #ifdef GHCI
28 -- These ones are defined only in stage2, and are
29 -- called only in stage2 (ie GHCI is on)
30 runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
31 tcTopSpliceExpr, lookupThName_maybe,
32 defaultRunMeta, runMeta', runRemoteModFinalizers,
33 finishTH
34 #endif
35 ) where
36
37 #include "HsVersions.h"
38
39 import HsSyn
40 import Annotations
41 import Name
42 import TcRnMonad
43 import TcType
44
45 import Outputable
46 import TcExpr
47 import SrcLoc
48 import THNames
49 import TcUnify
50 import TcEnv
51
52 import Control.Monad
53
54 #ifdef GHCI
55 import GHCi.Message
56 import GHCi.RemoteTypes
57 import GHCi
58 import HscMain
59 -- These imports are the reason that TcSplice
60 -- is very high up the module hierarchy
61 import RnSplice( traceSplice, SpliceInfo(..) )
62 import RdrName
63 import HscTypes
64 import Convert
65 import RnExpr
66 import RnEnv
67 import RnTypes
68 import TcHsSyn
69 import TcSimplify
70 import Type
71 import Kind
72 import NameSet
73 import TcMType
74 import TcHsType
75 import TcIface
76 import TyCoRep
77 import FamInst
78 import FamInstEnv
79 import InstEnv
80 import Inst
81 import NameEnv
82 import PrelNames
83 import TysWiredIn
84 import OccName
85 import Hooks
86 import Var
87 import Module
88 import LoadIface
89 import Class
90 import TyCon
91 import CoAxiom
92 import PatSyn
93 import ConLike
94 import DataCon
95 import TcEvidence( TcEvBinds(..) )
96 import Id
97 import IdInfo
98 import DsExpr
99 import DsMonad
100 import GHC.Serialized
101 import ErrUtils
102 import Util
103 import Unique
104 import VarSet ( isEmptyVarSet, filterVarSet, mkVarSet, elemVarSet )
105 import Data.List ( find )
106 import Data.Maybe
107 import FastString
108 import BasicTypes hiding( SuccessFlag(..) )
109 import Maybes( MaybeErr(..) )
110 import DynFlags
111 import Panic
112 import Lexeme
113
114 import qualified Language.Haskell.TH as TH
115 -- THSyntax gives access to internal functions and data types
116 import qualified Language.Haskell.TH.Syntax as TH
117
118 -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
119 import GHC.Desugar ( AnnotationWrapper(..) )
120
121 import qualified Data.IntSet as IntSet
122 import Control.Exception
123 import Data.Binary
124 import Data.Binary.Get
125 import qualified Data.ByteString as B
126 import qualified Data.ByteString.Lazy as LB
127 import Data.Dynamic ( fromDynamic, toDyn )
128 import qualified Data.Map as Map
129 import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )
130 import Data.Data (Data)
131 import Data.Proxy ( Proxy (..) )
132 import GHC.Exts ( unsafeCoerce# )
133 #endif
134
135 {-
136 ************************************************************************
137 * *
138 \subsection{Main interface + stubs for the non-GHCI case
139 * *
140 ************************************************************************
141 -}
142
143 tcTypedBracket :: HsBracket Name -> ExpRhoType -> TcM (HsExpr TcId)
144 tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)
145 tcSpliceExpr :: HsSplice Name -> ExpRhoType -> TcM (HsExpr TcId)
146 -- None of these functions add constraints to the LIE
147
148 -- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
149 -- runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName)
150 -- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)
151 -- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
152
153 runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
154 {-
155 ************************************************************************
156 * *
157 \subsection{Quoting an expression}
158 * *
159 ************************************************************************
160 -}
161
162 -- See Note [How brackets and nested splices are handled]
163 -- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
164 tcTypedBracket brack@(TExpBr expr) res_ty
165 = addErrCtxt (quotationCtxtDoc brack) $
166 do { cur_stage <- getStage
167 ; ps_ref <- newMutVar []
168 ; lie_var <- getConstraintVar -- Any constraints arising from nested splices
169 -- should get thrown into the constraint set
170 -- from outside the bracket
171
172 -- Typecheck expr to make sure it is valid,
173 -- Throw away the typechecked expression but return its type.
174 -- We'll typecheck it again when we splice it in somewhere
175 ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
176 tcInferRhoNC expr
177 -- NC for no context; tcBracket does that
178
179 ; meta_ty <- tcTExpTy expr_ty
180 ; ps' <- readMutVar ps_ref
181 ; texpco <- tcLookupId unsafeTExpCoerceName
182 ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
183 (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
184 (noLoc (HsTcBracketOut brack ps'))))
185 meta_ty res_ty }
186 tcTypedBracket other_brack _
187 = pprPanic "tcTypedBracket" (ppr other_brack)
188
189 -- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)
190 tcUntypedBracket brack ps res_ty
191 = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
192 ; ps' <- mapM tcPendingSplice ps
193 ; meta_ty <- tcBrackTy brack
194 ; traceTc "tc_bracket done untyped" (ppr meta_ty)
195 ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")
196 (HsTcBracketOut brack ps') meta_ty res_ty }
197
198 ---------------
199 tcBrackTy :: HsBracket Name -> TcM TcType
200 tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
201 tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp)
202 tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
203 tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
204 tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat)
205 tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL"
206 tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr"
207
208 ---------------
209 tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
210 tcPendingSplice (PendingRnSplice flavour splice_name expr)
211 = do { res_ty <- tcMetaTy meta_ty_name
212 ; expr' <- tcMonoExpr expr (mkCheckExpType res_ty)
213 ; return (PendingTcSplice splice_name expr') }
214 where
215 meta_ty_name = case flavour of
216 UntypedExpSplice -> expQTyConName
217 UntypedPatSplice -> patQTyConName
218 UntypedTypeSplice -> typeQTyConName
219 UntypedDeclSplice -> decsQTyConName
220
221 ---------------
222 -- Takes a tau and returns the type Q (TExp tau)
223 tcTExpTy :: TcType -> TcM TcType
224 tcTExpTy exp_ty
225 = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)
226 ; q <- tcLookupTyCon qTyConName
227 ; texp <- tcLookupTyCon tExpTyConName
228 ; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) }
229 where
230 err_msg ty
231 = vcat [ text "Illegal polytype:" <+> ppr ty
232 , text "The type of a Typed Template Haskell expression must" <+>
233 text "not have any quantification." ]
234
235 quotationCtxtDoc :: HsBracket Name -> SDoc
236 quotationCtxtDoc br_body
237 = hang (text "In the Template Haskell quotation")
238 2 (ppr br_body)
239
240
241 #ifndef GHCI
242 tcSpliceExpr e _ = failTH e "Template Haskell splice"
243
244 -- runQuasiQuoteExpr q = failTH q "quasiquote"
245 -- runQuasiQuotePat q = failTH q "pattern quasiquote"
246 -- runQuasiQuoteType q = failTH q "type quasiquote"
247 -- runQuasiQuoteDecl q = failTH q "declaration quasiquote"
248 runAnnotation _ q = failTH q "annotation"
249
250 #else
251 -- The whole of the rest of the file is the else-branch (ie stage2 only)
252
253 {-
254 Note [How top-level splices are handled]
255 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
256 Top-level splices (those not inside a [| .. |] quotation bracket) are handled
257 very straightforwardly:
258
259 1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
260
261 2. runMetaT: desugar, compile, run it, and convert result back to
262 HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,
263 HsExpr RdrName etc)
264
265 3. treat the result as if that's what you saw in the first place
266 e.g for HsType, rename and kind-check
267 for HsExpr, rename and type-check
268
269 (The last step is different for decls, because they can *only* be
270 top-level: we return the result of step 2.)
271
272 Note [How brackets and nested splices are handled]
273 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
274 Nested splices (those inside a [| .. |] quotation bracket),
275 are treated quite differently.
276
277 Remember, there are two forms of bracket
278 typed [|| e ||]
279 and untyped [| e |]
280
281 The life cycle of a typed bracket:
282 * Starts as HsBracket
283
284 * When renaming:
285 * Set the ThStage to (Brack s RnPendingTyped)
286 * Rename the body
287 * Result is still a HsBracket
288
289 * When typechecking:
290 * Set the ThStage to (Brack s (TcPending ps_var lie_var))
291 * Typecheck the body, and throw away the elaborated result
292 * Nested splices (which must be typed) are typechecked, and
293 the results accumulated in ps_var; their constraints
294 accumulate in lie_var
295 * Result is a HsTcBracketOut rn_brack pending_splices
296 where rn_brack is the incoming renamed bracket
297
298 The life cycle of a un-typed bracket:
299 * Starts as HsBracket
300
301 * When renaming:
302 * Set the ThStage to (Brack s (RnPendingUntyped ps_var))
303 * Rename the body
304 * Nested splices (which must be untyped) are renamed, and the
305 results accumulated in ps_var
306 * Result is still (HsRnBracketOut rn_body pending_splices)
307
308 * When typechecking a HsRnBracketOut
309 * Typecheck the pending_splices individually
310 * Ignore the body of the bracket; just check that the context
311 expects a bracket of that type (e.g. a [p| pat |] bracket should
312 be in a context needing a (Q Pat)
313 * Result is a HsTcBracketOut rn_brack pending_splices
314 where rn_brack is the incoming renamed bracket
315
316
317 In both cases, desugaring happens like this:
318 * HsTcBracketOut is desugared by DsMeta.dsBracket. It
319
320 a) Extends the ds_meta environment with the PendingSplices
321 attached to the bracket
322
323 b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
324 run, will produce a suitable TH expression/type/decl. This
325 is why we leave the *renamed* expression attached to the bracket:
326 the quoted expression should not be decorated with all the goop
327 added by the type checker
328
329 * Each splice carries a unique Name, called a "splice point", thus
330 ${n}(e). The name is initialised to an (Unqual "splice") when the
331 splice is created; the renamer gives it a unique.
332
333 * When DsMeta (used to desugar the body of the bracket) comes across
334 a splice, it looks up the splice's Name, n, in the ds_meta envt,
335 to find an (HsExpr Id) that should be substituted for the splice;
336 it just desugars it to get a CoreExpr (DsMeta.repSplice).
337
338 Example:
339 Source: f = [| Just $(g 3) |]
340 The [| |] part is a HsBracket
341
342 Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
343 The [| |] part is a HsBracketOut, containing *renamed*
344 (not typechecked) expression
345 The "s7" is the "splice point"; the (g Int 3) part
346 is a typechecked expression
347
348 Desugared: f = do { s7 <- g Int 3
349 ; return (ConE "Data.Maybe.Just" s7) }
350
351
352 Note [Template Haskell state diagram]
353 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
354 Here are the ThStages, s, their corresponding level numbers
355 (the result of (thLevel s)), and their state transitions.
356 The top level of the program is stage Comp:
357
358 Start here
359 |
360 V
361 ----------- $ ------------ $
362 | Comp | ---------> | Splice | -----|
363 | 1 | | 0 | <----|
364 ----------- ------------
365 ^ | ^ |
366 $ | | [||] $ | | [||]
367 | v | v
368 -------------- ----------------
369 | Brack Comp | | Brack Splice |
370 | 2 | | 1 |
371 -------------- ----------------
372
373 * Normal top-level declarations start in state Comp
374 (which has level 1).
375 Annotations start in state Splice, since they are
376 treated very like a splice (only without a '$')
377
378 * Code compiled in state Splice (and only such code)
379 will be *run at compile time*, with the result replacing
380 the splice
381
382 * The original paper used level -1 instead of 0, etc.
383
384 * The original paper did not allow a splice within a
385 splice, but there is no reason not to. This is the
386 $ transition in the top right.
387
388 Note [Template Haskell levels]
389 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
390 * Imported things are impLevel (= 0)
391
392 * However things at level 0 are not *necessarily* imported.
393 eg $( \b -> ... ) here b is bound at level 0
394
395 * In GHCi, variables bound by a previous command are treated
396 as impLevel, because we have bytecode for them.
397
398 * Variables are bound at the "current level"
399
400 * The current level starts off at outerLevel (= 1)
401
402 * The level is decremented by splicing $(..)
403 incremented by brackets [| |]
404 incremented by name-quoting 'f
405
406 When a variable is used, we compare
407 bind: binding level, and
408 use: current level at usage site
409
410 Generally
411 bind > use Always error (bound later than used)
412 [| \x -> $(f x) |]
413
414 bind = use Always OK (bound same stage as used)
415 [| \x -> $(f [| x |]) |]
416
417 bind < use Inside brackets, it depends
418 Inside splice, OK
419 Inside neither, OK
420
421 For (bind < use) inside brackets, there are three cases:
422 - Imported things OK f = [| map |]
423 - Top-level things OK g = [| f |]
424 - Non-top-level Only if there is a liftable instance
425 h = \(x:Int) -> [| x |]
426
427 To track top-level-ness we use the ThBindEnv in TcLclEnv
428
429 For example:
430 f = ...
431 g1 = $(map ...) is OK
432 g2 = $(f ...) is not OK; because we havn't compiled f yet
433
434 -}
435
436 {-
437 ************************************************************************
438 * *
439 \subsection{Splicing an expression}
440 * *
441 ************************************************************************
442 -}
443
444 tcSpliceExpr splice@(HsTypedSplice name expr) res_ty
445 = addErrCtxt (spliceCtxtDoc splice) $
446 setSrcSpan (getLoc expr) $ do
447 { stage <- getStage
448 ; case stage of
449 Splice {} -> tcTopSplice expr res_ty
450 Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty
451 RunSplice _ ->
452 -- See Note [RunSplice ThLevel] in "TcRnTypes".
453 pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++
454 "running another splice") (ppr splice)
455 Comp -> tcTopSplice expr res_ty
456 }
457 tcSpliceExpr splice _
458 = pprPanic "tcSpliceExpr" (ppr splice)
459
460 {- Note [Collecting modFinalizers in typed splices]
461 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
462
463 'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local
464 environment (see Note [Delaying modFinalizers in untyped splices] in
465 "RnSplice"). Thus after executing the splice, we move the finalizers to the
466 finalizer list in the global environment and set them to use the current local
467 environment (with 'addModFinalizersWithLclEnv').
468
469 -}
470
471 tcNestedSplice :: ThStage -> PendingStuff -> Name
472 -> LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id)
473 -- See Note [How brackets and nested splices are handled]
474 -- A splice inside brackets
475 tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty
476 = do { res_ty <- expTypeToType res_ty
477 ; meta_exp_ty <- tcTExpTy res_ty
478 ; expr' <- setStage pop_stage $
479 setConstraintVar lie_var $
480 tcMonoExpr expr (mkCheckExpType meta_exp_ty)
481 ; untypeq <- tcLookupId unTypeQName
482 ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'
483 ; ps <- readMutVar ps_var
484 ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
485
486 -- The returned expression is ignored; it's in the pending splices
487 ; return (panic "tcSpliceExpr") }
488
489 tcNestedSplice _ _ splice_name _ _
490 = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)
491
492 tcTopSplice :: LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id)
493 tcTopSplice expr res_ty
494 = do { -- Typecheck the expression,
495 -- making sure it has type Q (T res_ty)
496 res_ty <- expTypeToType res_ty
497 ; meta_exp_ty <- tcTExpTy res_ty
498 ; zonked_q_expr <- tcTopSpliceExpr Typed $
499 tcMonoExpr expr (mkCheckExpType meta_exp_ty)
500
501 -- See Note [Collecting modFinalizers in typed splices].
502 ; modfinalizers_ref <- newTcRef []
503 -- Run the expression
504 ; expr2 <- setStage (RunSplice modfinalizers_ref) $
505 runMetaE zonked_q_expr
506 ; mod_finalizers <- readTcRef modfinalizers_ref
507 ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
508 ; traceSplice (SpliceInfo { spliceDescription = "expression"
509 , spliceIsDecl = False
510 , spliceSource = Just expr
511 , spliceGenerated = ppr expr2 })
512
513 -- Rename and typecheck the spliced-in expression,
514 -- making sure it has type res_ty
515 -- These steps should never fail; this is a *typed* splice
516 ; addErrCtxt (spliceResultDoc expr) $ do
517 { (exp3, _fvs) <- rnLExpr expr2
518 ; exp4 <- tcMonoExpr exp3 (mkCheckExpType res_ty)
519 ; return (unLoc exp4) } }
520
521 {-
522 ************************************************************************
523 * *
524 \subsection{Error messages}
525 * *
526 ************************************************************************
527 -}
528
529 spliceCtxtDoc :: HsSplice Name -> SDoc
530 spliceCtxtDoc splice
531 = hang (text "In the Template Haskell splice")
532 2 (pprSplice splice)
533
534 spliceResultDoc :: LHsExpr Name -> SDoc
535 spliceResultDoc expr
536 = sep [ text "In the result of the splice:"
537 , nest 2 (char '$' <> pprParendLExpr expr)
538 , text "To see what the splice expanded to, use -ddump-splices"]
539
540 -------------------
541 tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr Id) -> TcM (LHsExpr Id)
542 -- Note [How top-level splices are handled]
543 -- Type check an expression that is the body of a top-level splice
544 -- (the caller will compile and run it)
545 -- Note that set the level to Splice, regardless of the original level,
546 -- before typechecking the expression. For example:
547 -- f x = $( ...$(g 3) ... )
548 -- The recursive call to tcPolyExpr will simply expand the
549 -- inner escape before dealing with the outer one
550
551 tcTopSpliceExpr isTypedSplice tc_action
552 = checkNoErrs $ -- checkNoErrs: must not try to run the thing
553 -- if the type checker fails!
554 unsetGOptM Opt_DeferTypeErrors $
555 -- Don't defer type errors. Not only are we
556 -- going to run this code, but we do an unsafe
557 -- coerce, so we get a seg-fault if, say we
558 -- splice a type into a place where an expression
559 -- is expected (Trac #7276)
560 setStage (Splice isTypedSplice) $
561 do { -- Typecheck the expression
562 (expr', wanted) <- captureConstraints tc_action
563 ; const_binds <- simplifyTop wanted
564
565 -- Zonk it and tie the knot of dictionary bindings
566 ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') }
567
568 {-
569 ************************************************************************
570 * *
571 Annotations
572 * *
573 ************************************************************************
574 -}
575
576 runAnnotation target expr = do
577 -- Find the classes we want instances for in order to call toAnnotationWrapper
578 loc <- getSrcSpanM
579 data_class <- tcLookupClass dataClassName
580 to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
581
582 -- Check the instances we require live in another module (we want to execute it..)
583 -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
584 -- also resolves the LIE constraints to detect e.g. instance ambiguity
585 zonked_wrapped_expr' <- tcTopSpliceExpr Untyped $
586 do { (expr', expr_ty) <- tcInferRhoNC expr
587 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
588 -- By instantiating the call >here< it gets registered in the
589 -- LIE consulted by tcTopSpliceExpr
590 -- and hence ensures the appropriate dictionary is bound by const_binds
591 ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
592 ; let specialised_to_annotation_wrapper_expr
593 = L loc (HsWrap wrapper
594 (HsVar (L loc to_annotation_wrapper_id)))
595 ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
596
597 -- Run the appropriately wrapped expression to get the value of
598 -- the annotation and its dictionaries. The return value is of
599 -- type AnnotationWrapper by construction, so this conversion is
600 -- safe
601 serialized <- runMetaAW zonked_wrapped_expr'
602 return Annotation {
603 ann_target = target,
604 ann_value = serialized
605 }
606
607 convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)
608 convertAnnotationWrapper fhv = do
609 dflags <- getDynFlags
610 if gopt Opt_ExternalInterpreter dflags
611 then do
612 Right <$> runTH THAnnWrapper fhv
613 else do
614 annotation_wrapper <- liftIO $ wormhole dflags fhv
615 return $ Right $
616 case unsafeCoerce# annotation_wrapper of
617 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
618 -- Got the value and dictionaries: build the serialized value and
619 -- call it a day. We ensure that we seq the entire serialized value
620 -- in order that any errors in the user-written code for the
621 -- annotation are exposed at this point. This is also why we are
622 -- doing all this stuff inside the context of runMeta: it has the
623 -- facilities to deal with user error in a meta-level expression
624 seqSerialized serialized `seq` serialized
625
626 -- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
627 seqSerialized :: Serialized -> ()
628 seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
629
630
631 {-
632 ************************************************************************
633 * *
634 \subsection{Running an expression}
635 * *
636 ************************************************************************
637 -}
638
639 runQuasi :: TH.Q a -> TcM a
640 runQuasi act = TH.runQ act
641
642 runRemoteModFinalizers :: ThModFinalizers -> TcM ()
643 runRemoteModFinalizers (ThModFinalizers finRefs) = do
644 dflags <- getDynFlags
645 let withForeignRefs [] f = f []
646 withForeignRefs (x : xs) f = withForeignRef x $ \r ->
647 withForeignRefs xs $ \rs -> f (r : rs)
648 if gopt Opt_ExternalInterpreter dflags then do
649 hsc_env <- env_top <$> getEnv
650 withIServ hsc_env $ \i -> do
651 tcg <- getGblEnv
652 th_state <- readTcRef (tcg_th_remote_state tcg)
653 case th_state of
654 Nothing -> return () -- TH was not started, nothing to do
655 Just fhv -> do
656 liftIO $ withForeignRef fhv $ \st ->
657 withForeignRefs finRefs $ \qrefs ->
658 writeIServ i (putMessage (RunModFinalizers st qrefs))
659 () <- runRemoteTH i []
660 readQResult i
661 else do
662 qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
663 runQuasi $ sequence_ qs
664
665 runQResult
666 :: (a -> String)
667 -> (SrcSpan -> a -> b)
668 -> (ForeignHValue -> TcM a)
669 -> SrcSpan
670 -> ForeignHValue {- TH.Q a -}
671 -> TcM b
672 runQResult show_th f runQ expr_span hval
673 = do { th_result <- runQ hval
674 ; traceTc "Got TH result:" (text (show_th th_result))
675 ; return (f expr_span th_result) }
676
677
678 -----------------
679 runMeta :: (MetaHook TcM -> LHsExpr Id -> TcM hs_syn)
680 -> LHsExpr Id
681 -> TcM hs_syn
682 runMeta unwrap e
683 = do { h <- getHooked runMetaHook defaultRunMeta
684 ; unwrap h e }
685
686 defaultRunMeta :: MetaHook TcM
687 defaultRunMeta (MetaE r)
688 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)
689 defaultRunMeta (MetaP r)
690 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)
691 defaultRunMeta (MetaT r)
692 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)
693 defaultRunMeta (MetaD r)
694 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)
695 defaultRunMeta (MetaAW r)
696 = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)
697 -- We turn off showing the code in meta-level exceptions because doing so exposes
698 -- the toAnnotationWrapper function that we slap around the users code
699
700 ----------------
701 runMetaAW :: LHsExpr Id -- Of type AnnotationWrapper
702 -> TcM Serialized
703 runMetaAW = runMeta metaRequestAW
704
705 runMetaE :: LHsExpr Id -- Of type (Q Exp)
706 -> TcM (LHsExpr RdrName)
707 runMetaE = runMeta metaRequestE
708
709 runMetaP :: LHsExpr Id -- Of type (Q Pat)
710 -> TcM (LPat RdrName)
711 runMetaP = runMeta metaRequestP
712
713 runMetaT :: LHsExpr Id -- Of type (Q Type)
714 -> TcM (LHsType RdrName)
715 runMetaT = runMeta metaRequestT
716
717 runMetaD :: LHsExpr Id -- Of type Q [Dec]
718 -> TcM [LHsDecl RdrName]
719 runMetaD = runMeta metaRequestD
720
721 ---------------
722 runMeta' :: Bool -- Whether code should be printed in the exception message
723 -> (hs_syn -> SDoc) -- how to print the code
724 -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x
725 -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that
726 -> TcM hs_syn -- Of type t
727 runMeta' show_code ppr_hs run_and_convert expr
728 = do { traceTc "About to run" (ppr expr)
729 ; recordThSpliceUse -- seems to be the best place to do this,
730 -- we catch all kinds of splices and annotations.
731
732 -- Check that we've had no errors of any sort so far.
733 -- For example, if we found an error in an earlier defn f, but
734 -- recovered giving it type f :: forall a.a, it'd be very dodgy
735 -- to carry ont. Mind you, the staging restrictions mean we won't
736 -- actually run f, but it still seems wrong. And, more concretely,
737 -- see Trac #5358 for an example that fell over when trying to
738 -- reify a function with a "?" kind in it. (These don't occur
739 -- in type-correct programs.
740 ; failIfErrsM
741
742 -- Desugar
743 ; ds_expr <- initDsTc (dsLExpr expr)
744 -- Compile and link it; might fail if linking fails
745 ; hsc_env <- getTopEnv
746 ; src_span <- getSrcSpanM
747 ; traceTc "About to run (desugared)" (ppr ds_expr)
748 ; either_hval <- tryM $ liftIO $
749 HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
750 ; case either_hval of {
751 Left exn -> fail_with_exn "compile and link" exn ;
752 Right hval -> do
753
754 { -- Coerce it to Q t, and run it
755
756 -- Running might fail if it throws an exception of any kind (hence tryAllM)
757 -- including, say, a pattern-match exception in the code we are running
758 --
759 -- We also do the TH -> HS syntax conversion inside the same
760 -- exception-cacthing thing so that if there are any lurking
761 -- exceptions in the data structure returned by hval, we'll
762 -- encounter them inside the try
763 --
764 -- See Note [Exceptions in TH]
765 let expr_span = getLoc expr
766 ; either_tval <- tryAllM $
767 setSrcSpan expr_span $ -- Set the span so that qLocation can
768 -- see where this splice is
769 do { mb_result <- run_and_convert expr_span hval
770 ; case mb_result of
771 Left err -> failWithTc err
772 Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
773 ; return $! result } }
774
775 ; case either_tval of
776 Right v -> return v
777 Left se -> case fromException se of
778 Just IOEnvFailure -> failM -- Error already in Tc monad
779 _ -> fail_with_exn "run" se -- Exception
780 }}}
781 where
782 -- see Note [Concealed TH exceptions]
783 fail_with_exn :: Exception e => String -> e -> TcM a
784 fail_with_exn phase exn = do
785 exn_msg <- liftIO $ Panic.safeShowException exn
786 let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
787 nest 2 (text exn_msg),
788 if show_code then text "Code:" <+> ppr expr else empty]
789 failWithTc msg
790
791 {-
792 Note [Exceptions in TH]
793 ~~~~~~~~~~~~~~~~~~~~~~~
794 Suppose we have something like this
795 $( f 4 )
796 where
797 f :: Int -> Q [Dec]
798 f n | n>3 = fail "Too many declarations"
799 | otherwise = ...
800
801 The 'fail' is a user-generated failure, and should be displayed as a
802 perfectly ordinary compiler error message, not a panic or anything
803 like that. Here's how it's processed:
804
805 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
806 effectively transforms (fail s) to
807 qReport True s >> fail
808 where 'qReport' comes from the Quasi class and fail from its monad
809 superclass.
810
811 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
812 (qReport True s) by using addErr to add an error message to the bag of errors.
813 The 'fail' in TcM raises an IOEnvFailure exception
814
815 * 'qReport' forces the message to ensure any exception hidden in unevaluated
816 thunk doesn't get into the bag of errors. Otherwise the following splice
817 will triger panic (Trac #8987):
818 $(fail undefined)
819 See also Note [Concealed TH exceptions]
820
821 * So, when running a splice, we catch all exceptions; then for
822 - an IOEnvFailure exception, we assume the error is already
823 in the error-bag (above)
824 - other errors, we add an error to the bag
825 and then fail
826
827 Note [Concealed TH exceptions]
828 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
829 When displaying the error message contained in an exception originated from TH
830 code, we need to make sure that the error message itself does not contain an
831 exception. For example, when executing the following splice:
832
833 $( error ("foo " ++ error "bar") )
834
835 the message for the outer exception is a thunk which will throw the inner
836 exception when evaluated.
837
838 For this reason, we display the message of a TH exception using the
839 'safeShowException' function, which recursively catches any exception thrown
840 when showing an error message.
841
842
843 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
844 -}
845
846 instance TH.Quasi TcM where
847 qNewName s = do { u <- newUnique
848 ; let i = getKey u
849 ; return (TH.mkNameU s i) }
850
851 -- 'msg' is forced to ensure exceptions don't escape,
852 -- see Note [Exceptions in TH]
853 qReport True msg = seqList msg $ addErr (text msg)
854 qReport False msg = seqList msg $ addWarn NoReason (text msg)
855
856 qLocation = do { m <- getModule
857 ; l <- getSrcSpanM
858 ; r <- case l of
859 UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
860 (ppr l)
861 RealSrcSpan s -> return s
862 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
863 , TH.loc_module = moduleNameString (moduleName m)
864 , TH.loc_package = unitIdString (moduleUnitId m)
865 , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
866 , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
867
868 qLookupName = lookupName
869 qReify = reify
870 qReifyFixity nm = lookupThName nm >>= reifyFixity
871 qReifyInstances = reifyInstances
872 qReifyRoles = reifyRoles
873 qReifyAnnotations = reifyAnnotations
874 qReifyModule = reifyModule
875 qReifyConStrictness nm = do { nm' <- lookupThName nm
876 ; dc <- tcLookupDataCon nm'
877 ; let bangs = dataConImplBangs dc
878 ; return (map reifyDecidedStrictness bangs) }
879
880 -- For qRecover, discard error messages if
881 -- the recovery action is chosen. Otherwise
882 -- we'll only fail higher up.
883 qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
884 ; case mb_res of
885 Just val -> do { addMessages msgs -- There might be warnings
886 ; return val }
887 Nothing -> recover -- Discard all msgs
888 }
889
890 qRunIO io = liftIO io
891
892 qAddDependentFile fp = do
893 ref <- fmap tcg_dependent_files getGblEnv
894 dep_files <- readTcRef ref
895 writeTcRef ref (fp:dep_files)
896
897 qAddTopDecls thds = do
898 l <- getSrcSpanM
899 let either_hval = convertToHsDecls l thds
900 ds <- case either_hval of
901 Left exn -> pprPanic "qAddTopDecls: can't convert top-level declarations" exn
902 Right ds -> return ds
903 mapM_ (checkTopDecl . unLoc) ds
904 th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
905 updTcRef th_topdecls_var (\topds -> ds ++ topds)
906 where
907 checkTopDecl :: HsDecl RdrName -> TcM ()
908 checkTopDecl (ValD binds)
909 = mapM_ bindName (collectHsBindBinders binds)
910 checkTopDecl (SigD _)
911 = return ()
912 checkTopDecl (AnnD _)
913 = return ()
914 checkTopDecl (ForD (ForeignImport { fd_name = L _ name }))
915 = bindName name
916 checkTopDecl _
917 = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"
918
919 bindName :: RdrName -> TcM ()
920 bindName (Exact n)
921 = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
922 ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
923 }
924
925 bindName name =
926 addErr $
927 hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))
928 2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
929
930 qAddModFinalizer fin = do
931 r <- liftIO $ mkRemoteRef fin
932 fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
933 addModFinalizerRef fref
934
935 qGetQ :: forall a. Typeable a => TcM (Maybe a)
936 qGetQ = do
937 th_state_var <- fmap tcg_th_state getGblEnv
938 th_state <- readTcRef th_state_var
939 -- See #10596 for why we use a scoped type variable here.
940 return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
941
942 qPutQ x = do
943 th_state_var <- fmap tcg_th_state getGblEnv
944 updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
945
946 qIsExtEnabled = xoptM
947
948 qExtsEnabled = do
949 dflags <- hsc_dflags <$> getTopEnv
950 return $ map toEnum $ IntSet.elems $ extensionFlags dflags
951
952 -- | Adds a mod finalizer reference to the local environment.
953 addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
954 addModFinalizerRef finRef = do
955 th_stage <- getStage
956 case th_stage of
957 RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)
958 -- This case happens only if a splice is executed and the caller does
959 -- not set the 'ThStage' to 'RunSplice' to collect finalizers.
960 -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
961 _ ->
962 pprPanic "addModFinalizer was called when no finalizers were collected"
963 (ppr th_stage)
964
965 -- | Releases the external interpreter state.
966 finishTH :: TcM ()
967 finishTH = do
968 dflags <- getDynFlags
969 when (gopt Opt_ExternalInterpreter dflags) $ do
970 tcg <- getGblEnv
971 writeTcRef (tcg_th_remote_state tcg) Nothing
972
973 runTHExp :: ForeignHValue -> TcM TH.Exp
974 runTHExp = runTH THExp
975
976 runTHPat :: ForeignHValue -> TcM TH.Pat
977 runTHPat = runTH THPat
978
979 runTHType :: ForeignHValue -> TcM TH.Type
980 runTHType = runTH THType
981
982 runTHDec :: ForeignHValue -> TcM [TH.Dec]
983 runTHDec = runTH THDec
984
985 runTH :: Binary a => THResultType -> ForeignHValue -> TcM a
986 runTH ty fhv = do
987 hsc_env <- env_top <$> getEnv
988 dflags <- getDynFlags
989 if not (gopt Opt_ExternalInterpreter dflags)
990 then do
991 -- Run it in the local TcM
992 hv <- liftIO $ wormhole dflags fhv
993 r <- runQuasi (unsafeCoerce# hv :: TH.Q a)
994 return r
995 else
996 -- Run it on the server. For an overview of how TH works with
997 -- Remote GHCi, see Note [Remote Template Haskell] in
998 -- libraries/ghci/GHCi/TH.hs.
999 withIServ hsc_env $ \i -> do
1000 rstate <- getTHState i
1001 loc <- TH.qLocation
1002 liftIO $
1003 withForeignRef rstate $ \state_hv ->
1004 withForeignRef fhv $ \q_hv ->
1005 writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))
1006 runRemoteTH i []
1007 bs <- readQResult i
1008 return $! runGet get (LB.fromStrict bs)
1009
1010
1011 -- | communicate with a remotely-running TH computation until it finishes.
1012 -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
1013 runRemoteTH
1014 :: IServ
1015 -> [Messages] -- saved from nested calls to qRecover
1016 -> TcM ()
1017 runRemoteTH iserv recovers = do
1018 THMsg msg <- liftIO $ readIServ iserv getTHMessage
1019 case msg of
1020 RunTHDone -> return ()
1021 StartRecover -> do -- Note [TH recover with -fexternal-interpreter]
1022 v <- getErrsVar
1023 msgs <- readTcRef v
1024 writeTcRef v emptyMessages
1025 runRemoteTH iserv (msgs : recovers)
1026 EndRecover caught_error -> do
1027 v <- getErrsVar
1028 let (prev_msgs, rest) = case recovers of
1029 [] -> panic "EndRecover"
1030 a : b -> (a,b)
1031 if caught_error
1032 then writeTcRef v prev_msgs
1033 else updTcRef v (unionMessages prev_msgs)
1034 runRemoteTH iserv rest
1035 _other -> do
1036 r <- handleTHMessage msg
1037 liftIO $ writeIServ iserv (put r)
1038 runRemoteTH iserv recovers
1039
1040 -- | Read a value of type QResult from the iserv
1041 readQResult :: Binary a => IServ -> TcM a
1042 readQResult i = do
1043 qr <- liftIO $ readIServ i get
1044 case qr of
1045 QDone a -> return a
1046 QException str -> liftIO $ throwIO (ErrorCall str)
1047 QFail str -> fail str
1048
1049 {- Note [TH recover with -fexternal-interpreter]
1050
1051 Recover is slightly tricky to implement.
1052
1053 The meaning of "recover a b" is
1054 - Do a
1055 - If it finished successfully, then keep the messages it generated
1056 - If it failed, discard any messages it generated, and do b
1057
1058 The messages are managed by GHC in the TcM monad, whereas the
1059 exception-handling is done in the ghc-iserv process, so we have to
1060 coordinate between the two.
1061
1062 On the server:
1063 - emit a StartRecover message
1064 - run "a" inside a catch
1065 - if it finishes, emit EndRecover False
1066 - if it fails, emit EndRecover True, then run "b"
1067
1068 Back in GHC, when we receive:
1069
1070 StartRecover
1071 save the current messages and start with an empty set.
1072 EndRecover caught_error
1073 Restore the previous messages,
1074 and merge in the new messages if caught_error is false.
1075 -}
1076
1077 -- | Retrieve (or create, if it hasn't been created already), the
1078 -- remote TH state. The TH state is a remote reference to an IORef
1079 -- QState living on the server, and we have to pass this to each RunTH
1080 -- call we make.
1081 --
1082 -- The TH state is stored in tcg_th_remote_state in the TcGblEnv.
1083 --
1084 getTHState :: IServ -> TcM (ForeignRef (IORef QState))
1085 getTHState i = do
1086 tcg <- getGblEnv
1087 th_state <- readTcRef (tcg_th_remote_state tcg)
1088 case th_state of
1089 Just rhv -> return rhv
1090 Nothing -> do
1091 hsc_env <- env_top <$> getEnv
1092 fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH
1093 writeTcRef (tcg_th_remote_state tcg) (Just fhv)
1094 return fhv
1095
1096 wrapTHResult :: TcM a -> TcM (THResult a)
1097 wrapTHResult tcm = do
1098 e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic
1099 case e of
1100 Left e -> return (THException (show e))
1101 Right a -> return (THComplete a)
1102
1103 handleTHMessage :: THMessage a -> TcM a
1104 handleTHMessage msg = case msg of
1105 NewName a -> wrapTHResult $ TH.qNewName a
1106 Report b str -> wrapTHResult $ TH.qReport b str
1107 LookupName b str -> wrapTHResult $ TH.qLookupName b str
1108 Reify n -> wrapTHResult $ TH.qReify n
1109 ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
1110 ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
1111 ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
1112 ReifyAnnotations lookup tyrep ->
1113 wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
1114 ReifyModule m -> wrapTHResult $ TH.qReifyModule m
1115 ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
1116 AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
1117 AddModFinalizer r -> do
1118 hsc_env <- env_top <$> getEnv
1119 wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
1120 AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
1121 IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
1122 ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
1123 _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
1124
1125 getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
1126 getAnnotationsByTypeRep th_name tyrep
1127 = do { name <- lookupThAnnLookup th_name
1128 ; topEnv <- getTopEnv
1129 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1130 ; tcg <- getGblEnv
1131 ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep
1132 ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep
1133 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1134
1135 {-
1136 ************************************************************************
1137 * *
1138 Instance Testing
1139 * *
1140 ************************************************************************
1141 -}
1142
1143 reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
1144 reifyInstances th_nm th_tys
1145 = addErrCtxt (text "In the argument of reifyInstances:"
1146 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
1147 do { loc <- getSrcSpanM
1148 ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)
1149 -- #9262 says to bring vars into scope, like in HsForAllTy case
1150 -- of rnHsTyKi
1151 ; free_vars <- extractHsTyRdrTyVars rdr_ty
1152 ; let tv_rdrs = freeKiTyVarsAllVars free_vars
1153 -- Rename to HsType Name
1154 ; ((tv_names, rn_ty), _fvs)
1155 <- bindLRdrNames tv_rdrs $ \ tv_names ->
1156 do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
1157 ; return ((tv_names, rn_ty), fvs) }
1158 ; (_tvs, ty)
1159 <- solveEqualities $
1160 tcImplicitTKBndrsType tv_names $
1161 fst <$> tcLHsType rn_ty
1162 ; ty <- zonkTcTypeToType emptyZonkEnv ty
1163 -- Substitute out the meta type variables
1164 -- In particular, the type might have kind
1165 -- variables inside it (Trac #7477)
1166
1167 ; traceTc "reifyInstances" (ppr ty $$ ppr (typeKind ty))
1168 ; case splitTyConApp_maybe ty of -- This expands any type synonyms
1169 Just (tc, tys) -- See Trac #7910
1170 | Just cls <- tyConClass_maybe tc
1171 -> do { inst_envs <- tcGetInstEnvs
1172 ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys
1173 ; traceTc "reifyInstances1" (ppr matches)
1174 ; reifyClassInstances cls (map fst matches ++ unifies) }
1175 | isOpenFamilyTyCon tc
1176 -> do { inst_envs <- tcGetFamInstEnvs
1177 ; let matches = lookupFamInstEnv inst_envs tc tys
1178 ; traceTc "reifyInstances2" (ppr matches)
1179 ; reifyFamilyInstances tc (map fim_instance matches) }
1180 _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))
1181 2 (text "is not a class constraint or type family application")) }
1182 where
1183 doc = ClassInstanceCtx
1184 bale_out msg = failWithTc msg
1185
1186 cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName)
1187 cvt loc th_ty = case convertToHsType loc th_ty of
1188 Left msg -> failWithTc msg
1189 Right ty -> return ty
1190
1191 {-
1192 ************************************************************************
1193 * *
1194 Reification
1195 * *
1196 ************************************************************************
1197 -}
1198
1199 lookupName :: Bool -- True <=> type namespace
1200 -- False <=> value namespace
1201 -> String -> TcM (Maybe TH.Name)
1202 lookupName is_type_name s
1203 = do { lcl_env <- getLocalRdrEnv
1204 ; case lookupLocalRdrEnv lcl_env rdr_name of
1205 Just n -> return (Just (reifyName n))
1206 Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name
1207 ; return (fmap reifyName mb_nm) } }
1208 where
1209 th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M'
1210
1211 occ_fs :: FastString
1212 occ_fs = mkFastString (TH.nameBase th_name)
1213
1214 occ :: OccName
1215 occ | is_type_name
1216 = if isLexCon occ_fs then mkTcOccFS occ_fs
1217 else mkTyVarOccFS occ_fs
1218 | otherwise
1219 = if isLexCon occ_fs then mkDataOccFS occ_fs
1220 else mkVarOccFS occ_fs
1221
1222 rdr_name = case TH.nameModule th_name of
1223 Nothing -> mkRdrUnqual occ
1224 Just mod -> mkRdrQual (mkModuleName mod) occ
1225
1226 getThing :: TH.Name -> TcM TcTyThing
1227 getThing th_name
1228 = do { name <- lookupThName th_name
1229 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
1230 ; tcLookupTh name }
1231 -- ToDo: this tcLookup could fail, which would give a
1232 -- rather unhelpful error message
1233 where
1234 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
1235 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
1236 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
1237 ppr_ns _ = panic "reify/ppr_ns"
1238
1239 reify :: TH.Name -> TcM TH.Info
1240 reify th_name
1241 = do { traceTc "reify 1" (text (TH.showName th_name))
1242 ; thing <- getThing th_name
1243 ; traceTc "reify 2" (ppr thing)
1244 ; reifyThing thing }
1245
1246 lookupThName :: TH.Name -> TcM Name
1247 lookupThName th_name = do
1248 mb_name <- lookupThName_maybe th_name
1249 case mb_name of
1250 Nothing -> failWithTc (notInScope th_name)
1251 Just name -> return name
1252
1253 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
1254 lookupThName_maybe th_name
1255 = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
1256 -- Pick the first that works
1257 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
1258 ; return (listToMaybe names) }
1259 where
1260 lookup rdr_name
1261 = do { -- Repeat much of lookupOccRn, because we want
1262 -- to report errors in a TH-relevant way
1263 ; rdr_env <- getLocalRdrEnv
1264 ; case lookupLocalRdrEnv rdr_env rdr_name of
1265 Just name -> return (Just name)
1266 Nothing -> lookupGlobalOccRn_maybe rdr_name }
1267
1268 tcLookupTh :: Name -> TcM TcTyThing
1269 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
1270 -- it gives a reify-related error message on failure, whereas in the normal
1271 -- tcLookup, failure is a bug.
1272 tcLookupTh name
1273 = do { (gbl_env, lcl_env) <- getEnvs
1274 ; case lookupNameEnv (tcl_env lcl_env) name of {
1275 Just thing -> return thing;
1276 Nothing ->
1277
1278 case lookupNameEnv (tcg_type_env gbl_env) name of {
1279 Just thing -> return (AGlobal thing);
1280 Nothing ->
1281
1282 -- EZY: I don't think this choice matters, no TH in signatures!
1283 if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name
1284 then -- It's defined in this module
1285 failWithTc (notInEnv name)
1286
1287 else
1288 do { mb_thing <- tcLookupImported_maybe name
1289 ; case mb_thing of
1290 Succeeded thing -> return (AGlobal thing)
1291 Failed msg -> failWithTc msg
1292 }}}}
1293
1294 notInScope :: TH.Name -> SDoc
1295 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
1296 text "is not in scope at a reify"
1297 -- Ugh! Rather an indirect way to display the name
1298
1299 notInEnv :: Name -> SDoc
1300 notInEnv name = quotes (ppr name) <+>
1301 text "is not in the type environment at a reify"
1302
1303 ------------------------------
1304 reifyRoles :: TH.Name -> TcM [TH.Role]
1305 reifyRoles th_name
1306 = do { thing <- getThing th_name
1307 ; case thing of
1308 AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
1309 _ -> failWithTc (text "No roles associated with" <+> (ppr thing))
1310 }
1311 where
1312 reify_role Nominal = TH.NominalR
1313 reify_role Representational = TH.RepresentationalR
1314 reify_role Phantom = TH.PhantomR
1315
1316 ------------------------------
1317 reifyThing :: TcTyThing -> TcM TH.Info
1318 -- The only reason this is monadic is for error reporting,
1319 -- which in turn is mainly for the case when TH can't express
1320 -- some random GHC extension
1321
1322 reifyThing (AGlobal (AnId id))
1323 = do { ty <- reifyType (idType id)
1324 ; let v = reifyName id
1325 ; case idDetails id of
1326 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))
1327 RecSelId{sel_tycon=RecSelData tc}
1328 -> return (TH.VarI (reifySelector id tc) ty Nothing)
1329 _ -> return (TH.VarI v ty Nothing)
1330 }
1331
1332 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
1333 reifyThing (AGlobal (AConLike (RealDataCon dc)))
1334 = do { let name = dataConName dc
1335 ; ty <- reifyType (idType (dataConWrapId dc))
1336 ; return (TH.DataConI (reifyName name) ty
1337 (reifyName (dataConOrigTyCon dc)))
1338 }
1339
1340 reifyThing (AGlobal (AConLike (PatSynCon ps)))
1341 = do { let name = reifyName ps
1342 ; ty <- reifyPatSynType (patSynSig ps)
1343 ; return (TH.PatSynI name ty) }
1344
1345 reifyThing (ATcId {tct_id = id})
1346 = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
1347 -- though it may be incomplete
1348 ; ty2 <- reifyType ty1
1349 ; return (TH.VarI (reifyName id) ty2 Nothing) }
1350
1351 reifyThing (ATyVar tv tv1)
1352 = do { ty1 <- zonkTcTyVar tv1
1353 ; ty2 <- reifyType ty1
1354 ; return (TH.TyVarI (reifyName tv) ty2) }
1355
1356 reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
1357
1358 -------------------------------------------
1359 reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
1360 reifyAxBranch fam_tc (CoAxBranch { cab_lhs = args, cab_rhs = rhs })
1361 -- remove kind patterns (#8884)
1362 = do { args' <- mapM reifyType (filterOutInvisibleTypes fam_tc args)
1363 ; rhs' <- reifyType rhs
1364 ; return (TH.TySynEqn args' rhs') }
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 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1822 | isTupleTyCon tc = if isPromotedDataCon tc
1823 then TH.PromotedTupleT arity
1824 else TH.TupleT arity
1825 | tc `hasKey` listTyConKey = TH.ListT
1826 | tc `hasKey` nilDataConKey = TH.PromotedNilT
1827 | tc `hasKey` consDataConKey = TH.PromotedConsT
1828 | tc `hasKey` heqTyConKey = TH.EqualityT
1829 | tc `hasKey` eqPrimTyConKey = TH.EqualityT
1830 | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
1831 | otherwise = TH.ConT (reifyName tc)
1832
1833 -- See Note [Kind annotations on TyConApps]
1834 maybe_sig_t th_type
1835 | needs_kind_sig
1836 = do { let full_kind = typeKind (mkTyConApp tc tys)
1837 ; th_full_kind <- reifyKind full_kind
1838 ; return (TH.SigT th_type th_full_kind) }
1839 | otherwise
1840 = return th_type
1841
1842 needs_kind_sig
1843 | GT <- compareLength tys tc_binders
1844 , tcIsTyVarTy tc_res_kind
1845 = True
1846 | otherwise
1847 = not $
1848 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 -}
2013
2014 #endif /* GHCI */