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