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