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