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