Fix #14888 by adding more special cases for ArrowT
[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 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 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 (L loc to_annotation_wrapper_id)))
586 ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
587
588 -- Run the appropriately wrapped expression to get the value of
589 -- the annotation and its dictionaries. The return value is of
590 -- type AnnotationWrapper by construction, so this conversion is
591 -- safe
592 serialized <- runMetaAW zonked_wrapped_expr'
593 return Annotation {
594 ann_target = target,
595 ann_value = serialized
596 }
597
598 convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)
599 convertAnnotationWrapper fhv = do
600 dflags <- getDynFlags
601 if gopt Opt_ExternalInterpreter dflags
602 then do
603 Right <$> runTH THAnnWrapper fhv
604 else do
605 annotation_wrapper <- liftIO $ wormhole dflags fhv
606 return $ Right $
607 case unsafeCoerce# annotation_wrapper of
608 AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
609 -- Got the value and dictionaries: build the serialized value and
610 -- call it a day. We ensure that we seq the entire serialized value
611 -- in order that any errors in the user-written code for the
612 -- annotation are exposed at this point. This is also why we are
613 -- doing all this stuff inside the context of runMeta: it has the
614 -- facilities to deal with user error in a meta-level expression
615 seqSerialized serialized `seq` serialized
616
617 -- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
618 seqSerialized :: Serialized -> ()
619 seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
620
621
622 {-
623 ************************************************************************
624 * *
625 \subsection{Running an expression}
626 * *
627 ************************************************************************
628 -}
629
630 runQuasi :: TH.Q a -> TcM a
631 runQuasi act = TH.runQ act
632
633 runRemoteModFinalizers :: ThModFinalizers -> TcM ()
634 runRemoteModFinalizers (ThModFinalizers finRefs) = do
635 dflags <- getDynFlags
636 let withForeignRefs [] f = f []
637 withForeignRefs (x : xs) f = withForeignRef x $ \r ->
638 withForeignRefs xs $ \rs -> f (r : rs)
639 if gopt Opt_ExternalInterpreter dflags then do
640 hsc_env <- env_top <$> getEnv
641 withIServ hsc_env $ \i -> do
642 tcg <- getGblEnv
643 th_state <- readTcRef (tcg_th_remote_state tcg)
644 case th_state of
645 Nothing -> return () -- TH was not started, nothing to do
646 Just fhv -> do
647 liftIO $ withForeignRef fhv $ \st ->
648 withForeignRefs finRefs $ \qrefs ->
649 writeIServ i (putMessage (RunModFinalizers st qrefs))
650 () <- runRemoteTH i []
651 readQResult i
652 else do
653 qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
654 runQuasi $ sequence_ qs
655
656 runQResult
657 :: (a -> String)
658 -> (SrcSpan -> a -> b)
659 -> (ForeignHValue -> TcM a)
660 -> SrcSpan
661 -> ForeignHValue {- TH.Q a -}
662 -> TcM b
663 runQResult show_th f runQ expr_span hval
664 = do { th_result <- runQ hval
665 ; traceTc "Got TH result:" (text (show_th th_result))
666 ; return (f expr_span th_result) }
667
668
669 -----------------
670 runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn)
671 -> LHsExpr GhcTc
672 -> TcM hs_syn
673 runMeta unwrap e
674 = do { h <- getHooked runMetaHook defaultRunMeta
675 ; unwrap h e }
676
677 defaultRunMeta :: MetaHook TcM
678 defaultRunMeta (MetaE r)
679 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)
680 defaultRunMeta (MetaP r)
681 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)
682 defaultRunMeta (MetaT r)
683 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)
684 defaultRunMeta (MetaD r)
685 = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)
686 defaultRunMeta (MetaAW r)
687 = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)
688 -- We turn off showing the code in meta-level exceptions because doing so exposes
689 -- the toAnnotationWrapper function that we slap around the user's code
690
691 ----------------
692 runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper
693 -> TcM Serialized
694 runMetaAW = runMeta metaRequestAW
695
696 runMetaE :: LHsExpr GhcTc -- Of type (Q Exp)
697 -> TcM (LHsExpr GhcPs)
698 runMetaE = runMeta metaRequestE
699
700 runMetaP :: LHsExpr GhcTc -- Of type (Q Pat)
701 -> TcM (LPat GhcPs)
702 runMetaP = runMeta metaRequestP
703
704 runMetaT :: LHsExpr GhcTc -- Of type (Q Type)
705 -> TcM (LHsType GhcPs)
706 runMetaT = runMeta metaRequestT
707
708 runMetaD :: LHsExpr GhcTc -- Of type Q [Dec]
709 -> TcM [LHsDecl GhcPs]
710 runMetaD = runMeta metaRequestD
711
712 ---------------
713 runMeta' :: Bool -- Whether code should be printed in the exception message
714 -> (hs_syn -> SDoc) -- how to print the code
715 -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x
716 -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or
717 -- something like that
718 -> TcM hs_syn -- Of type t
719 runMeta' show_code ppr_hs run_and_convert expr
720 = do { traceTc "About to run" (ppr expr)
721 ; recordThSpliceUse -- seems to be the best place to do this,
722 -- we catch all kinds of splices and annotations.
723
724 -- Check that we've had no errors of any sort so far.
725 -- For example, if we found an error in an earlier defn f, but
726 -- recovered giving it type f :: forall a.a, it'd be very dodgy
727 -- to carry ont. Mind you, the staging restrictions mean we won't
728 -- actually run f, but it still seems wrong. And, more concretely,
729 -- see Trac #5358 for an example that fell over when trying to
730 -- reify a function with a "?" kind in it. (These don't occur
731 -- in type-correct programs.
732 ; failIfErrsM
733
734 -- Desugar
735 ; ds_expr <- initDsTc (dsLExpr expr)
736 -- Compile and link it; might fail if linking fails
737 ; hsc_env <- getTopEnv
738 ; src_span <- getSrcSpanM
739 ; traceTc "About to run (desugared)" (ppr ds_expr)
740 ; either_hval <- tryM $ liftIO $
741 HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
742 ; case either_hval of {
743 Left exn -> fail_with_exn "compile and link" exn ;
744 Right hval -> do
745
746 { -- Coerce it to Q t, and run it
747
748 -- Running might fail if it throws an exception of any kind (hence tryAllM)
749 -- including, say, a pattern-match exception in the code we are running
750 --
751 -- We also do the TH -> HS syntax conversion inside the same
752 -- exception-cacthing thing so that if there are any lurking
753 -- exceptions in the data structure returned by hval, we'll
754 -- encounter them inside the try
755 --
756 -- See Note [Exceptions in TH]
757 let expr_span = getLoc expr
758 ; either_tval <- tryAllM $
759 setSrcSpan expr_span $ -- Set the span so that qLocation can
760 -- see where this splice is
761 do { mb_result <- run_and_convert expr_span hval
762 ; case mb_result of
763 Left err -> failWithTc err
764 Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
765 ; return $! result } }
766
767 ; case either_tval of
768 Right v -> return v
769 Left se -> case fromException se of
770 Just IOEnvFailure -> failM -- Error already in Tc monad
771 _ -> fail_with_exn "run" se -- Exception
772 }}}
773 where
774 -- see Note [Concealed TH exceptions]
775 fail_with_exn :: Exception e => String -> e -> TcM a
776 fail_with_exn phase exn = do
777 exn_msg <- liftIO $ Panic.safeShowException exn
778 let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
779 nest 2 (text exn_msg),
780 if show_code then text "Code:" <+> ppr expr else empty]
781 failWithTc msg
782
783 {-
784 Note [Exceptions in TH]
785 ~~~~~~~~~~~~~~~~~~~~~~~
786 Suppose we have something like this
787 $( f 4 )
788 where
789 f :: Int -> Q [Dec]
790 f n | n>3 = fail "Too many declarations"
791 | otherwise = ...
792
793 The 'fail' is a user-generated failure, and should be displayed as a
794 perfectly ordinary compiler error message, not a panic or anything
795 like that. Here's how it's processed:
796
797 * 'fail' is the monad fail. The monad instance for Q in TH.Syntax
798 effectively transforms (fail s) to
799 qReport True s >> fail
800 where 'qReport' comes from the Quasi class and fail from its monad
801 superclass.
802
803 * The TcM monad is an instance of Quasi (see TcSplice), and it implements
804 (qReport True s) by using addErr to add an error message to the bag of errors.
805 The 'fail' in TcM raises an IOEnvFailure exception
806
807 * 'qReport' forces the message to ensure any exception hidden in unevaluated
808 thunk doesn't get into the bag of errors. Otherwise the following splice
809 will triger panic (Trac #8987):
810 $(fail undefined)
811 See also Note [Concealed TH exceptions]
812
813 * So, when running a splice, we catch all exceptions; then for
814 - an IOEnvFailure exception, we assume the error is already
815 in the error-bag (above)
816 - other errors, we add an error to the bag
817 and then fail
818
819 Note [Concealed TH exceptions]
820 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
821 When displaying the error message contained in an exception originated from TH
822 code, we need to make sure that the error message itself does not contain an
823 exception. For example, when executing the following splice:
824
825 $( error ("foo " ++ error "bar") )
826
827 the message for the outer exception is a thunk which will throw the inner
828 exception when evaluated.
829
830 For this reason, we display the message of a TH exception using the
831 'safeShowException' function, which recursively catches any exception thrown
832 when showing an error message.
833
834
835 To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
836 -}
837
838 instance TH.Quasi TcM where
839 qNewName s = do { u <- newUnique
840 ; let i = getKey u
841 ; return (TH.mkNameU s i) }
842
843 -- 'msg' is forced to ensure exceptions don't escape,
844 -- see Note [Exceptions in TH]
845 qReport True msg = seqList msg $ addErr (text msg)
846 qReport False msg = seqList msg $ addWarn NoReason (text msg)
847
848 qLocation = do { m <- getModule
849 ; l <- getSrcSpanM
850 ; r <- case l of
851 UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
852 (ppr l)
853 RealSrcSpan s -> return s
854 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
855 , TH.loc_module = moduleNameString (moduleName m)
856 , TH.loc_package = unitIdString (moduleUnitId m)
857 , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
858 , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
859
860 qLookupName = lookupName
861 qReify = reify
862 qReifyFixity nm = lookupThName nm >>= reifyFixity
863 qReifyInstances = reifyInstances
864 qReifyRoles = reifyRoles
865 qReifyAnnotations = reifyAnnotations
866 qReifyModule = reifyModule
867 qReifyConStrictness nm = do { nm' <- lookupThName nm
868 ; dc <- tcLookupDataCon nm'
869 ; let bangs = dataConImplBangs dc
870 ; return (map reifyDecidedStrictness bangs) }
871
872 -- For qRecover, discard error messages if
873 -- the recovery action is chosen. Otherwise
874 -- we'll only fail higher up.
875 qRecover recover main = tryTcDiscardingErrs recover main
876
877 qAddDependentFile fp = do
878 ref <- fmap tcg_dependent_files getGblEnv
879 dep_files <- readTcRef ref
880 writeTcRef ref (fp:dep_files)
881
882 qAddTopDecls thds = do
883 l <- getSrcSpanM
884 let either_hval = convertToHsDecls l thds
885 ds <- case either_hval of
886 Left exn -> pprPanic "qAddTopDecls: can't convert top-level declarations" exn
887 Right ds -> return ds
888 mapM_ (checkTopDecl . unLoc) ds
889 th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
890 updTcRef th_topdecls_var (\topds -> ds ++ topds)
891 where
892 checkTopDecl :: HsDecl GhcPs -> TcM ()
893 checkTopDecl (ValD binds)
894 = mapM_ bindName (collectHsBindBinders binds)
895 checkTopDecl (SigD _)
896 = return ()
897 checkTopDecl (AnnD _)
898 = return ()
899 checkTopDecl (ForD (ForeignImport { fd_name = L _ name }))
900 = bindName name
901 checkTopDecl _
902 = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"
903
904 bindName :: RdrName -> TcM ()
905 bindName (Exact n)
906 = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
907 ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
908 }
909
910 bindName name =
911 addErr $
912 hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))
913 2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
914
915 qAddForeignFile lang str = do
916 var <- fmap tcg_th_foreign_files getGblEnv
917 updTcRef var ((lang, str) :)
918
919 qAddModFinalizer fin = do
920 r <- liftIO $ mkRemoteRef fin
921 fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
922 addModFinalizerRef fref
923
924 qAddCorePlugin plugin = do
925 hsc_env <- env_top <$> getEnv
926 r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)
927 let err = hang
928 (text "addCorePlugin: invalid plugin module "
929 <+> text (show plugin)
930 )
931 2
932 (text "Plugins in the current package can't be specified.")
933 case r of
934 Found {} -> addErr err
935 FoundMultiple {} -> addErr err
936 _ -> return ()
937 th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
938 updTcRef th_coreplugins_var (plugin:)
939
940 qGetQ :: forall a. Typeable a => TcM (Maybe a)
941 qGetQ = do
942 th_state_var <- fmap tcg_th_state getGblEnv
943 th_state <- readTcRef th_state_var
944 -- See #10596 for why we use a scoped type variable here.
945 return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
946
947 qPutQ x = do
948 th_state_var <- fmap tcg_th_state getGblEnv
949 updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
950
951 qIsExtEnabled = xoptM
952
953 qExtsEnabled =
954 EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
955
956 -- | Adds a mod finalizer reference to the local environment.
957 addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
958 addModFinalizerRef finRef = do
959 th_stage <- getStage
960 case th_stage of
961 RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)
962 -- This case happens only if a splice is executed and the caller does
963 -- not set the 'ThStage' to 'RunSplice' to collect finalizers.
964 -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
965 _ ->
966 pprPanic "addModFinalizer was called when no finalizers were collected"
967 (ppr th_stage)
968
969 -- | Releases the external interpreter state.
970 finishTH :: TcM ()
971 finishTH = do
972 dflags <- getDynFlags
973 when (gopt Opt_ExternalInterpreter dflags) $ do
974 tcg <- getGblEnv
975 writeTcRef (tcg_th_remote_state tcg) Nothing
976
977 runTHExp :: ForeignHValue -> TcM TH.Exp
978 runTHExp = runTH THExp
979
980 runTHPat :: ForeignHValue -> TcM TH.Pat
981 runTHPat = runTH THPat
982
983 runTHType :: ForeignHValue -> TcM TH.Type
984 runTHType = runTH THType
985
986 runTHDec :: ForeignHValue -> TcM [TH.Dec]
987 runTHDec = runTH THDec
988
989 runTH :: Binary a => THResultType -> ForeignHValue -> TcM a
990 runTH ty fhv = do
991 hsc_env <- env_top <$> getEnv
992 dflags <- getDynFlags
993 if not (gopt Opt_ExternalInterpreter dflags)
994 then do
995 -- Run it in the local TcM
996 hv <- liftIO $ wormhole dflags fhv
997 r <- runQuasi (unsafeCoerce# hv :: TH.Q a)
998 return r
999 else
1000 -- Run it on the server. For an overview of how TH works with
1001 -- Remote GHCi, see Note [Remote Template Haskell] in
1002 -- libraries/ghci/GHCi/TH.hs.
1003 withIServ hsc_env $ \i -> do
1004 rstate <- getTHState i
1005 loc <- TH.qLocation
1006 liftIO $
1007 withForeignRef rstate $ \state_hv ->
1008 withForeignRef fhv $ \q_hv ->
1009 writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))
1010 runRemoteTH i []
1011 bs <- readQResult i
1012 return $! runGet get (LB.fromStrict bs)
1013
1014
1015 -- | communicate with a remotely-running TH computation until it finishes.
1016 -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
1017 runRemoteTH
1018 :: IServ
1019 -> [Messages] -- saved from nested calls to qRecover
1020 -> TcM ()
1021 runRemoteTH iserv recovers = do
1022 THMsg msg <- liftIO $ readIServ iserv getTHMessage
1023 case msg of
1024 RunTHDone -> return ()
1025 StartRecover -> do -- Note [TH recover with -fexternal-interpreter]
1026 v <- getErrsVar
1027 msgs <- readTcRef v
1028 writeTcRef v emptyMessages
1029 runRemoteTH iserv (msgs : recovers)
1030 EndRecover caught_error -> do
1031 v <- getErrsVar
1032 let (prev_msgs, rest) = case recovers of
1033 [] -> panic "EndRecover"
1034 a : b -> (a,b)
1035 if caught_error
1036 then writeTcRef v prev_msgs
1037 else updTcRef v (unionMessages prev_msgs)
1038 runRemoteTH iserv rest
1039 _other -> do
1040 r <- handleTHMessage msg
1041 liftIO $ writeIServ iserv (put r)
1042 runRemoteTH iserv recovers
1043
1044 -- | Read a value of type QResult from the iserv
1045 readQResult :: Binary a => IServ -> TcM a
1046 readQResult i = do
1047 qr <- liftIO $ readIServ i get
1048 case qr of
1049 QDone a -> return a
1050 QException str -> liftIO $ throwIO (ErrorCall str)
1051 QFail str -> fail str
1052
1053 {- Note [TH recover with -fexternal-interpreter]
1054
1055 Recover is slightly tricky to implement.
1056
1057 The meaning of "recover a b" is
1058 - Do a
1059 - If it finished successfully, then keep the messages it generated
1060 - If it failed, discard any messages it generated, and do b
1061
1062 The messages are managed by GHC in the TcM monad, whereas the
1063 exception-handling is done in the ghc-iserv process, so we have to
1064 coordinate between the two.
1065
1066 On the server:
1067 - emit a StartRecover message
1068 - run "a" inside a catch
1069 - if it finishes, emit EndRecover False
1070 - if it fails, emit EndRecover True, then run "b"
1071
1072 Back in GHC, when we receive:
1073
1074 StartRecover
1075 save the current messages and start with an empty set.
1076 EndRecover caught_error
1077 Restore the previous messages,
1078 and merge in the new messages if caught_error is false.
1079 -}
1080
1081 -- | Retrieve (or create, if it hasn't been created already), the
1082 -- remote TH state. The TH state is a remote reference to an IORef
1083 -- QState living on the server, and we have to pass this to each RunTH
1084 -- call we make.
1085 --
1086 -- The TH state is stored in tcg_th_remote_state in the TcGblEnv.
1087 --
1088 getTHState :: IServ -> TcM (ForeignRef (IORef QState))
1089 getTHState i = do
1090 tcg <- getGblEnv
1091 th_state <- readTcRef (tcg_th_remote_state tcg)
1092 case th_state of
1093 Just rhv -> return rhv
1094 Nothing -> do
1095 hsc_env <- env_top <$> getEnv
1096 fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH
1097 writeTcRef (tcg_th_remote_state tcg) (Just fhv)
1098 return fhv
1099
1100 wrapTHResult :: TcM a -> TcM (THResult a)
1101 wrapTHResult tcm = do
1102 e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic
1103 case e of
1104 Left e -> return (THException (show e))
1105 Right a -> return (THComplete a)
1106
1107 handleTHMessage :: THMessage a -> TcM a
1108 handleTHMessage msg = case msg of
1109 NewName a -> wrapTHResult $ TH.qNewName a
1110 Report b str -> wrapTHResult $ TH.qReport b str
1111 LookupName b str -> wrapTHResult $ TH.qLookupName b str
1112 Reify n -> wrapTHResult $ TH.qReify n
1113 ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
1114 ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
1115 ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
1116 ReifyAnnotations lookup tyrep ->
1117 wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
1118 ReifyModule m -> wrapTHResult $ TH.qReifyModule m
1119 ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
1120 AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
1121 AddModFinalizer r -> do
1122 hsc_env <- env_top <$> getEnv
1123 wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
1124 AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
1125 AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
1126 AddForeignFile lang str -> wrapTHResult $ TH.qAddForeignFile lang str
1127 IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
1128 ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
1129 _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
1130
1131 getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
1132 getAnnotationsByTypeRep th_name tyrep
1133 = do { name <- lookupThAnnLookup th_name
1134 ; topEnv <- getTopEnv
1135 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1136 ; tcg <- getGblEnv
1137 ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep
1138 ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep
1139 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1140
1141 {-
1142 ************************************************************************
1143 * *
1144 Instance Testing
1145 * *
1146 ************************************************************************
1147 -}
1148
1149 reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
1150 reifyInstances th_nm th_tys
1151 = addErrCtxt (text "In the argument of reifyInstances:"
1152 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
1153 do { loc <- getSrcSpanM
1154 ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)
1155 -- #9262 says to bring vars into scope, like in HsForAllTy case
1156 -- of rnHsTyKi
1157 ; free_vars <- extractHsTyRdrTyVars rdr_ty
1158 ; let tv_rdrs = freeKiTyVarsAllVars free_vars
1159 -- Rename to HsType Name
1160 ; ((tv_names, rn_ty), _fvs)
1161 <- checkNoErrs $ -- If there are out-of-scope Names here, then we
1162 -- must error before proceeding to typecheck the
1163 -- renamed type, as that will result in GHC
1164 -- internal errors (#13837).
1165 bindLRdrNames tv_rdrs $ \ tv_names ->
1166 do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
1167 ; return ((tv_names, rn_ty), fvs) }
1168 ; (_tvs, ty)
1169 <- solveEqualities $
1170 tcImplicitTKBndrsType tv_names $
1171 fst <$> tcLHsType rn_ty
1172 ; ty <- zonkTcTypeToType emptyZonkEnv ty
1173 -- Substitute out the meta type variables
1174 -- In particular, the type might have kind
1175 -- variables inside it (Trac #7477)
1176
1177 ; traceTc "reifyInstances" (ppr ty $$ ppr (typeKind ty))
1178 ; case splitTyConApp_maybe ty of -- This expands any type synonyms
1179 Just (tc, tys) -- See Trac #7910
1180 | Just cls <- tyConClass_maybe tc
1181 -> do { inst_envs <- tcGetInstEnvs
1182 ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys
1183 ; traceTc "reifyInstances1" (ppr matches)
1184 ; reifyClassInstances cls (map fst matches ++ unifies) }
1185 | isOpenFamilyTyCon tc
1186 -> do { inst_envs <- tcGetFamInstEnvs
1187 ; let matches = lookupFamInstEnv inst_envs tc tys
1188 ; traceTc "reifyInstances2" (ppr matches)
1189 ; reifyFamilyInstances tc (map fim_instance matches) }
1190 _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))
1191 2 (text "is not a class constraint or type family application")) }
1192 where
1193 doc = ClassInstanceCtx
1194 bale_out msg = failWithTc msg
1195
1196 cvt :: SrcSpan -> TH.Type -> TcM (LHsType GhcPs)
1197 cvt loc th_ty = case convertToHsType loc th_ty of
1198 Left msg -> failWithTc msg
1199 Right ty -> return ty
1200
1201 {-
1202 ************************************************************************
1203 * *
1204 Reification
1205 * *
1206 ************************************************************************
1207 -}
1208
1209 lookupName :: Bool -- True <=> type namespace
1210 -- False <=> value namespace
1211 -> String -> TcM (Maybe TH.Name)
1212 lookupName is_type_name s
1213 = do { lcl_env <- getLocalRdrEnv
1214 ; case lookupLocalRdrEnv lcl_env rdr_name of
1215 Just n -> return (Just (reifyName n))
1216 Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name
1217 ; return (fmap reifyName mb_nm) } }
1218 where
1219 th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M'
1220
1221 occ_fs :: FastString
1222 occ_fs = mkFastString (TH.nameBase th_name)
1223
1224 occ :: OccName
1225 occ | is_type_name
1226 = if isLexVarSym occ_fs || isLexCon occ_fs
1227 then mkTcOccFS occ_fs
1228 else mkTyVarOccFS occ_fs
1229 | otherwise
1230 = if isLexCon occ_fs then mkDataOccFS occ_fs
1231 else mkVarOccFS occ_fs
1232
1233 rdr_name = case TH.nameModule th_name of
1234 Nothing -> mkRdrUnqual occ
1235 Just mod -> mkRdrQual (mkModuleName mod) occ
1236
1237 getThing :: TH.Name -> TcM TcTyThing
1238 getThing th_name
1239 = do { name <- lookupThName th_name
1240 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
1241 ; tcLookupTh name }
1242 -- ToDo: this tcLookup could fail, which would give a
1243 -- rather unhelpful error message
1244 where
1245 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
1246 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
1247 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
1248 ppr_ns _ = panic "reify/ppr_ns"
1249
1250 reify :: TH.Name -> TcM TH.Info
1251 reify th_name
1252 = do { traceTc "reify 1" (text (TH.showName th_name))
1253 ; thing <- getThing th_name
1254 ; traceTc "reify 2" (ppr thing)
1255 ; reifyThing thing }
1256
1257 lookupThName :: TH.Name -> TcM Name
1258 lookupThName th_name = do
1259 mb_name <- lookupThName_maybe th_name
1260 case mb_name of
1261 Nothing -> failWithTc (notInScope th_name)
1262 Just name -> return name
1263
1264 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
1265 lookupThName_maybe th_name
1266 = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
1267 -- Pick the first that works
1268 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
1269 ; return (listToMaybe names) }
1270 where
1271 lookup rdr_name
1272 = do { -- Repeat much of lookupOccRn, because we want
1273 -- to report errors in a TH-relevant way
1274 ; rdr_env <- getLocalRdrEnv
1275 ; case lookupLocalRdrEnv rdr_env rdr_name of
1276 Just name -> return (Just name)
1277 Nothing -> lookupGlobalOccRn_maybe rdr_name }
1278
1279 tcLookupTh :: Name -> TcM TcTyThing
1280 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
1281 -- it gives a reify-related error message on failure, whereas in the normal
1282 -- tcLookup, failure is a bug.
1283 tcLookupTh name
1284 = do { (gbl_env, lcl_env) <- getEnvs
1285 ; case lookupNameEnv (tcl_env lcl_env) name of {
1286 Just thing -> return thing;
1287 Nothing ->
1288
1289 case lookupNameEnv (tcg_type_env gbl_env) name of {
1290 Just thing -> return (AGlobal thing);
1291 Nothing ->
1292
1293 -- EZY: I don't think this choice matters, no TH in signatures!
1294 if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name
1295 then -- It's defined in this module
1296 failWithTc (notInEnv name)
1297
1298 else
1299 do { mb_thing <- tcLookupImported_maybe name
1300 ; case mb_thing of
1301 Succeeded thing -> return (AGlobal thing)
1302 Failed msg -> failWithTc msg
1303 }}}}
1304
1305 notInScope :: TH.Name -> SDoc
1306 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
1307 text "is not in scope at a reify"
1308 -- Ugh! Rather an indirect way to display the name
1309
1310 notInEnv :: Name -> SDoc
1311 notInEnv name = quotes (ppr name) <+>
1312 text "is not in the type environment at a reify"
1313
1314 ------------------------------
1315 reifyRoles :: TH.Name -> TcM [TH.Role]
1316 reifyRoles th_name
1317 = do { thing <- getThing th_name
1318 ; case thing of
1319 AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
1320 _ -> failWithTc (text "No roles associated with" <+> (ppr thing))
1321 }
1322 where
1323 reify_role Nominal = TH.NominalR
1324 reify_role Representational = TH.RepresentationalR
1325 reify_role Phantom = TH.PhantomR
1326
1327 ------------------------------
1328 reifyThing :: TcTyThing -> TcM TH.Info
1329 -- The only reason this is monadic is for error reporting,
1330 -- which in turn is mainly for the case when TH can't express
1331 -- some random GHC extension
1332
1333 reifyThing (AGlobal (AnId id))
1334 = do { ty <- reifyType (idType id)
1335 ; let v = reifyName id
1336 ; case idDetails id of
1337 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))
1338 RecSelId{sel_tycon=RecSelData tc}
1339 -> return (TH.VarI (reifySelector id tc) ty Nothing)
1340 _ -> return (TH.VarI v ty Nothing)
1341 }
1342
1343 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
1344 reifyThing (AGlobal (AConLike (RealDataCon dc)))
1345 = do { let name = dataConName dc
1346 ; ty <- reifyType (idType (dataConWrapId dc))
1347 ; return (TH.DataConI (reifyName name) ty
1348 (reifyName (dataConOrigTyCon dc)))
1349 }
1350
1351 reifyThing (AGlobal (AConLike (PatSynCon ps)))
1352 = do { let name = reifyName ps
1353 ; ty <- reifyPatSynType (patSynSig ps)
1354 ; return (TH.PatSynI name ty) }
1355
1356 reifyThing (ATcId {tct_id = id})
1357 = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
1358 -- though it may be incomplete
1359 ; ty2 <- reifyType ty1
1360 ; return (TH.VarI (reifyName id) ty2 Nothing) }
1361
1362 reifyThing (ATyVar tv tv1)
1363 = do { ty1 <- zonkTcTyVar tv1
1364 ; ty2 <- reifyType ty1
1365 ; return (TH.TyVarI (reifyName tv) ty2) }
1366
1367 reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
1368
1369 -------------------------------------------
1370 reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
1371 reifyAxBranch fam_tc (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
1372 -- remove kind patterns (#8884)
1373 = do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
1374 ; lhs' <- reifyTypes lhs_types_only
1375 ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)
1376 lhs_types_only lhs'
1377 ; rhs' <- reifyType rhs
1378 ; return (TH.TySynEqn annot_th_lhs rhs') }
1379 where
1380 fam_tvs = tyConVisibleTyVars fam_tc
1381
1382 reifyTyCon :: TyCon -> TcM TH.Info
1383 reifyTyCon tc
1384 | Just cls <- tyConClass_maybe tc
1385 = reifyClass cls
1386
1387 | isFunTyCon tc
1388 = return (TH.PrimTyConI (reifyName tc) 2 False)
1389
1390 | isPrimTyCon tc
1391 = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnliftedTyCon tc))
1392
1393 | isTypeFamilyTyCon tc
1394 = do { let tvs = tyConTyVars tc
1395 res_kind = tyConResKind tc
1396 resVar = famTcResVar tc
1397
1398 ; kind' <- reifyKind res_kind
1399 ; let (resultSig, injectivity) =
1400 case resVar of
1401 Nothing -> (TH.KindSig kind', Nothing)
1402 Just name ->
1403 let thName = reifyName name
1404 injAnnot = tyConInjectivityInfo tc
1405 sig = TH.TyVarSig (TH.KindedTV thName kind')
1406 inj = case injAnnot of
1407 NotInjective -> Nothing
1408 Injective ms ->
1409 Just (TH.InjectivityAnn thName injRHS)
1410 where
1411 injRHS = map (reifyName . tyVarName)
1412 (filterByList ms tvs)
1413 in (sig, inj)
1414 ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
1415 ; let tfHead =
1416 TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity
1417 ; if isOpenTypeFamilyTyCon tc
1418 then do { fam_envs <- tcGetFamInstEnvs
1419 ; instances <- reifyFamilyInstances tc
1420 (familyInstances fam_envs tc)
1421 ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) }
1422 else do { eqns <-
1423 case isClosedSynFamilyTyConWithAxiom_maybe tc of
1424 Just ax -> mapM (reifyAxBranch tc) $
1425 fromBranches $ coAxiomBranches ax
1426 Nothing -> return []
1427 ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns)
1428 []) } }
1429
1430 | isDataFamilyTyCon tc
1431 = do { let res_kind = tyConResKind tc
1432
1433 ; kind' <- fmap Just (reifyKind res_kind)
1434
1435 ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
1436 ; fam_envs <- tcGetFamInstEnvs
1437 ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)
1438 ; return (TH.FamilyI
1439 (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }
1440
1441 | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym
1442 = do { rhs' <- reifyType rhs
1443 ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
1444 ; return (TH.TyConI
1445 (TH.TySynD (reifyName tc) tvs' rhs'))
1446 }
1447
1448 | otherwise
1449 = do { cxt <- reifyCxt (tyConStupidTheta tc)
1450 ; let tvs = tyConTyVars tc
1451 dataCons = tyConDataCons tc
1452 isGadt = isGadtSyntaxTyCon tc
1453 ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
1454 ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc)
1455 ; let name = reifyName tc
1456 deriv = [] -- Don't know about deriving
1457 decl | isNewTyCon tc =
1458 TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv
1459 | otherwise =
1460 TH.DataD cxt name r_tvs Nothing cons deriv
1461 ; return (TH.TyConI decl) }
1462
1463 reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con
1464 reifyDataCon isGadtDataCon tys dc
1465 = do { let -- used for H98 data constructors
1466 (ex_tvs, theta, arg_tys)
1467 = dataConInstSig dc tys
1468 -- used for GADTs data constructors
1469 g_user_tvs' = dataConUserTyVars dc
1470 (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty')
1471 = dataConFullSig dc
1472 (srcUnpks, srcStricts)
1473 = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
1474 dcdBangs = zipWith TH.Bang srcUnpks srcStricts
1475 fields = dataConFieldLabels dc
1476 name = reifyName dc
1477 -- Universal tvs present in eq_spec need to be filtered out, as
1478 -- they will not appear anywhere in the type.
1479 eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec)
1480
1481 ; (univ_subst, _)
1482 -- See Note [Freshen reified GADT constructors' universal tyvars]
1483 <- freshenTyVarBndrs $
1484 filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs
1485 ; let (tvb_subst, g_user_tvs)
1486 = mapAccumL substTyVarBndr univ_subst g_user_tvs'
1487 g_theta = substTys tvb_subst g_theta'
1488 g_arg_tys = substTys tvb_subst g_arg_tys'
1489 g_res_ty = substTy tvb_subst g_res_ty'
1490
1491 ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
1492
1493 ; main_con <-
1494 if | not (null fields) && not isGadtDataCon ->
1495 return $ TH.RecC name (zip3 (map reifyFieldLabel fields)
1496 dcdBangs r_arg_tys)
1497 | not (null fields) -> do
1498 { res_ty <- reifyType g_res_ty
1499 ; return $ TH.RecGadtC [name]
1500 (zip3 (map (reifyName . flSelector) fields)
1501 dcdBangs r_arg_tys) res_ty }
1502 -- We need to check not isGadtDataCon here because GADT
1503 -- constructors can be declared infix.
1504 -- See Note [Infix GADT constructors] in TcTyClsDecls.
1505 | dataConIsInfix dc && not isGadtDataCon ->
1506 ASSERT( arg_tys `lengthIs` 2 ) do
1507 { let [r_a1, r_a2] = r_arg_tys
1508 [s1, s2] = dcdBangs
1509 ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
1510 | isGadtDataCon -> do
1511 { res_ty <- reifyType g_res_ty
1512 ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }
1513 | otherwise ->
1514 return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
1515
1516 ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)
1517 | otherwise = (ex_tvs, theta)
1518 ret_con | null ex_tvs' && null theta' = return main_con
1519 | otherwise = do
1520 { cxt <- reifyCxt theta'
1521 ; ex_tvs'' <- reifyTyVars ex_tvs'
1522 ; return (TH.ForallC ex_tvs'' cxt main_con) }
1523 ; ASSERT( arg_tys `equalLength` dcdBangs )
1524 ret_con }
1525
1526 {-
1527 Note [Freshen reified GADT constructors' universal tyvars]
1528 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1529 Suppose one were to reify this GADT:
1530
1531 data a :~: b where
1532 Refl :: forall a b. (a ~ b) => a :~: b
1533
1534 We ought to be careful here about the uniques we give to the occurrences of `a`
1535 and `b` in this definition. That is because in the original DataCon, all uses
1536 of `a` and `b` have the same unique, since `a` and `b` are both universally
1537 quantified type variables--that is, they are used in both the (:~:) tycon as
1538 well as in the constructor type signature. But when we turn the DataCon
1539 definition into the reified one, the `a` and `b` in the constructor type
1540 signature becomes differently scoped than the `a` and `b` in `data a :~: b`.
1541
1542 While it wouldn't technically be *wrong* per se to re-use the same uniques for
1543 `a` and `b` across these two different scopes, it's somewhat annoying for end
1544 users of Template Haskell, since they wouldn't be able to rely on the
1545 assumption that all TH names have globally distinct uniques (#13885). For this
1546 reason, we freshen the universally quantified tyvars that go into the reified
1547 GADT constructor type signature to give them distinct uniques from their
1548 counterparts in the tycon.
1549 -}
1550
1551 ------------------------------
1552 reifyClass :: Class -> TcM TH.Info
1553 reifyClass cls
1554 = do { cxt <- reifyCxt theta
1555 ; inst_envs <- tcGetInstEnvs
1556 ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
1557 ; assocTys <- concatMapM reifyAT ats
1558 ; ops <- concatMapM reify_op op_stuff
1559 ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls))
1560 ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
1561 ; return (TH.ClassI dec insts) }
1562 where
1563 (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
1564 fds' = map reifyFunDep fds
1565 reify_op (op, def_meth)
1566 = do { ty <- reifyType (idType op)
1567 ; let nm' = reifyName op
1568 ; case def_meth of
1569 Just (_, GenericDM gdm_ty) ->
1570 do { gdm_ty' <- reifyType gdm_ty
1571 ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty'] }
1572 _ -> return [TH.SigD nm' ty] }
1573
1574 reifyAT :: ClassATItem -> TcM [TH.Dec]
1575 reifyAT (ATI tycon def) = do
1576 tycon' <- reifyTyCon tycon
1577 case tycon' of
1578 TH.FamilyI dec _ -> do
1579 let (tyName, tyArgs) = tfNames dec
1580 (dec :) <$> maybe (return [])
1581 (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
1582 def
1583 _ -> pprPanic "reifyAT" (text (show tycon'))
1584
1585 reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
1586 reifyDefImpl n args ty =
1587 TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty
1588
1589 tfNames :: TH.Dec -> (TH.Name, [TH.Name])
1590 tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
1591 = (n, map bndrName args)
1592 tfNames d = pprPanic "tfNames" (text (show d))
1593
1594 bndrName :: TH.TyVarBndr -> TH.Name
1595 bndrName (TH.PlainTV n) = n
1596 bndrName (TH.KindedTV n _) = n
1597
1598 ------------------------------
1599 -- | Annotate (with TH.SigT) a type if the first parameter is True
1600 -- and if the type contains a free variable.
1601 -- This is used to annotate type patterns for poly-kinded tyvars in
1602 -- reifying class and type instances. See #8953 and th/T8953.
1603 annotThType :: Bool -- True <=> annotate
1604 -> TyCoRep.Type -> TH.Type -> TcM TH.Type
1605 -- tiny optimization: if the type is annotated, don't annotate again.
1606 annotThType _ _ th_ty@(TH.SigT {}) = return th_ty
1607 annotThType True ty th_ty
1608 | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
1609 = do { let ki = typeKind ty
1610 ; th_ki <- reifyKind ki
1611 ; return (TH.SigT th_ty th_ki) }
1612 annotThType _ _ th_ty = return th_ty
1613
1614 -- | For every type variable in the input,
1615 -- report whether or not the tv is poly-kinded. This is used to eventually
1616 -- feed into 'annotThType'.
1617 mkIsPolyTvs :: [TyVar] -> [Bool]
1618 mkIsPolyTvs = map is_poly_tv
1619 where
1620 is_poly_tv tv = not $
1621 isEmptyVarSet $
1622 filterVarSet isTyVar $
1623 tyCoVarsOfType $
1624 tyVarKind tv
1625
1626 ------------------------------
1627 reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
1628 reifyClassInstances cls insts
1629 = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
1630 where
1631 tvs = tyConVisibleTyVars (classTyCon cls)
1632
1633 reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1634 -- includes only *visible* tvs
1635 -> ClsInst -> TcM TH.Dec
1636 reifyClassInstance is_poly_tvs i
1637 = do { cxt <- reifyCxt theta
1638 ; let vis_types = filterOutInvisibleTypes cls_tc types
1639 ; thtypes <- reifyTypes vis_types
1640 ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
1641 ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
1642 ; return $ (TH.InstanceD over cxt head_ty []) }
1643 where
1644 (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
1645 cls_tc = classTyCon cls
1646 dfun = instanceDFunId i
1647 over = case overlapMode (is_flag i) of
1648 NoOverlap _ -> Nothing
1649 Overlappable _ -> Just TH.Overlappable
1650 Overlapping _ -> Just TH.Overlapping
1651 Overlaps _ -> Just TH.Overlaps
1652 Incoherent _ -> Just TH.Incoherent
1653
1654 ------------------------------
1655 reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
1656 reifyFamilyInstances fam_tc fam_insts
1657 = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
1658 where
1659 fam_tvs = tyConVisibleTyVars fam_tc
1660
1661 reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1662 -- includes only *visible* tvs
1663 -> FamInst -> TcM TH.Dec
1664 reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
1665 , fi_fam = fam
1666 , fi_tvs = fam_tvs
1667 , fi_tys = lhs
1668 , fi_rhs = rhs })
1669 = case flavor of
1670 SynFamilyInst ->
1671 -- remove kind patterns (#8884)
1672 do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
1673 ; th_lhs <- reifyTypes lhs_types_only
1674 ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
1675 th_lhs
1676 ; th_rhs <- reifyType rhs
1677 ; return (TH.TySynInstD (reifyName fam)
1678 (TH.TySynEqn annot_th_lhs th_rhs)) }
1679
1680 DataFamilyInst rep_tc ->
1681 do { let rep_tvs = tyConTyVars rep_tc
1682 fam' = reifyName fam
1683
1684 -- eta-expand lhs types, because sometimes data/newtype
1685 -- instances are eta-reduced; See Trac #9692
1686 -- See Note [Eta reduction for data family axioms]
1687 -- in TcInstDcls
1688 (_rep_tc, rep_tc_args) = splitTyConApp rhs
1689 etad_tyvars = dropList rep_tc_args rep_tvs
1690 etad_tys = mkTyVarTys etad_tyvars
1691 eta_expanded_tvs = mkTyVarTys fam_tvs `chkAppend` etad_tys
1692 eta_expanded_lhs = lhs `chkAppend` etad_tys
1693 dataCons = tyConDataCons rep_tc
1694 isGadt = isGadtSyntaxTyCon rep_tc
1695 ; cons <- mapM (reifyDataCon isGadt eta_expanded_tvs) dataCons
1696 ; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs
1697 ; th_tys <- reifyTypes types_only
1698 ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
1699 ; return $
1700 if isNewTyCon rep_tc
1701 then TH.NewtypeInstD [] fam' annot_th_tys Nothing (head cons) []
1702 else TH.DataInstD [] fam' annot_th_tys Nothing cons []
1703 }
1704 where
1705 fam_tc = famInstTyCon inst
1706
1707 ------------------------------
1708 reifyType :: TyCoRep.Type -> TcM TH.Type
1709 -- Monadic only because of failure
1710 reifyType ty | isLiftedTypeKind ty = return TH.StarT
1711 | isConstraintKind ty = return TH.ConstraintT
1712 reifyType ty@(ForAllTy {}) = reify_for_all ty
1713 reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) }
1714 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1715 reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
1716 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1717 reifyType ty@(FunTy t1 t2)
1718 | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
1719 | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1720 reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH
1721 reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)
1722
1723 reify_for_all :: TyCoRep.Type -> TcM TH.Type
1724 reify_for_all ty
1725 = do { cxt' <- reifyCxt cxt;
1726 ; tau' <- reifyType tau
1727 ; tvs' <- reifyTyVars tvs
1728 ; return (TH.ForallT tvs' cxt' tau') }
1729 where
1730 (tvs, cxt, tau) = tcSplitSigmaTy ty
1731
1732 reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
1733 reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
1734 reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
1735
1736 reifyTypes :: [Type] -> TcM [TH.Type]
1737 reifyTypes = mapM reifyType
1738
1739 reifyPatSynType
1740 :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type
1741 -- reifies a pattern synonym's type and returns its *complete* type
1742 -- signature; see NOTE [Pattern synonym signatures and Template
1743 -- Haskell]
1744 reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
1745 = do { univTyVars' <- reifyTyVars univTyVars
1746 ; req' <- reifyCxt req
1747 ; exTyVars' <- reifyTyVars exTyVars
1748 ; prov' <- reifyCxt prov
1749 ; tau' <- reifyType (mkFunTys argTys resTy)
1750 ; return $ TH.ForallT univTyVars' req'
1751 $ TH.ForallT exTyVars' prov' tau' }
1752
1753 reifyKind :: Kind -> TcM TH.Kind
1754 reifyKind = reifyType
1755
1756 reifyCxt :: [PredType] -> TcM [TH.Pred]
1757 reifyCxt = mapM reifyPred
1758
1759 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1760 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1761
1762 reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr]
1763 reifyTyVars tvs = mapM reify_tv tvs
1764 where
1765 -- even if the kind is *, we need to include a kind annotation,
1766 -- in case a poly-kind would be inferred without the annotation.
1767 -- See #8953 or test th/T8953
1768 reify_tv tv = TH.KindedTV name <$> reifyKind kind
1769 where
1770 kind = tyVarKind tv
1771 name = reifyName tv
1772
1773 {-
1774 Note [Kind annotations on TyConApps]
1775 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1776 A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.
1777 For example:
1778
1779 type family F a :: k
1780 type instance F Int = (Proxy :: * -> *)
1781 type instance F Bool = (Proxy :: (* -> *) -> *)
1782
1783 It's hard to figure out where these annotations should appear, so we do this:
1784 Suppose we have a tycon application (T ty1 ... tyn). Assuming that T is not
1785 oversatured (more on this later), we can assume T's declaration is of the form
1786 T (tvb1 :: s1) ... (tvbn :: sn) :: p. If any kind variable that
1787 is free in p is not free in an injective position in tvb1 ... tvbn,
1788 then we put on a kind annotation, since we would not otherwise be able to infer
1789 the kind of the whole tycon application.
1790
1791 The injective positions in a tyvar binder are the injective positions in the
1792 kind of its tyvar, provided the tyvar binder is either:
1793
1794 * Anonymous. For example, in the promoted data constructor '(:):
1795
1796 '(:) :: forall a. a -> [a] -> [a]
1797
1798 The second and third tyvar binders (of kinds `a` and `[a]`) are both
1799 anonymous, so if we had '(:) 'True '[], then the inferred kinds of 'True and
1800 '[] would contribute to the inferred kind of '(:) 'True '[].
1801 * Has required visibility. For example, in the type family:
1802
1803 type family Wurble k (a :: k) :: k
1804 Wurble :: forall k -> k -> k
1805
1806 The first tyvar binder (of kind `forall k`) has required visibility, so if
1807 we had Wurble (Maybe a) Nothing, then the inferred kind of Maybe a would
1808 contribute to the inferred kind of Wurble (Maybe a) Nothing.
1809
1810 An injective position in a type is one that does not occur as an argument to
1811 a non-injective type constructor (e.g., non-injective type families). See
1812 injectiveVarsOfType.
1813
1814 How can be sure that this is correct? That is, how can we be sure that in the
1815 event that we leave off a kind annotation, that one could infer the kind of the
1816 tycon application from its arguments? It's essentially a proof by induction: if
1817 we can infer the kinds of every subtree of a type, then the whole tycon
1818 application will have an inferrable kind--unless, of course, the remainder of
1819 the tycon application's kind has uninstantiated kind variables.
1820
1821 An earlier implementation of this algorithm only checked if p contained any
1822 free variables. But this was unsatisfactory, since a datatype like this:
1823
1824 data Foo = Foo (Proxy '[False, True])
1825
1826 Would be reified like this:
1827
1828 data Foo = Foo (Proxy ('(:) False ('(:) True ('[] :: [Bool])
1829 :: [Bool]) :: [Bool]))
1830
1831 Which has a rather excessive amount of kind annotations. With the current
1832 algorithm, we instead reify Foo to this:
1833
1834 data Foo = Foo (Proxy ('(:) False ('(:) True ('[] :: [Bool]))))
1835
1836 Since in the case of '[], the kind p is [a], and there are no arguments in the
1837 kind of '[]. On the other hand, in the case of '(:) True '[], the kind p is
1838 (forall a. [a]), but a occurs free in the first and second arguments of the
1839 full kind of '(:), which is (forall a. a -> [a] -> [a]). (See Trac #14060.)
1840
1841 What happens if T is oversaturated? That is, if T's kind has fewer than n
1842 arguments, in the case that the concrete application instantiates a result
1843 kind variable with an arrow kind? If we run out of arguments, we do not attach
1844 a kind annotation. This should be a rare case, indeed. Here is an example:
1845
1846 data T1 :: k1 -> k2 -> *
1847 data T2 :: k1 -> k2 -> *
1848
1849 type family G (a :: k) :: k
1850 type instance G T1 = T2
1851
1852 type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above
1853
1854 Here G's kind is (forall k. k -> k), and the desugared RHS of that last
1855 instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
1856 the algorithm above, there are 3 arguments to G so we should peel off 3
1857 arguments in G's kind. But G's kind has only two arguments. This is the
1858 rare special case, and we choose not to annotate the application of G with
1859 a kind signature. After all, we needn't do this, since that instance would
1860 be reified as:
1861
1862 type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool
1863
1864 So the kind of G isn't ambiguous anymore due to the explicit kind annotation
1865 on its argument. See #8953 and test th/T8953.
1866 -}
1867
1868 reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
1869 reify_tc_app tc tys
1870 = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
1871 ; maybe_sig_t (mkThAppTs r_tc tys') }
1872 where
1873 arity = tyConArity tc
1874 tc_binders = tyConBinders tc
1875 tc_res_kind = tyConResKind tc
1876
1877 r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2)
1878 | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2)
1879 | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2)
1880 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
1881 | isTupleTyCon tc = if isPromotedDataCon tc
1882 then TH.PromotedTupleT arity
1883 else TH.TupleT arity
1884 | tc `hasKey` funTyConKey = TH.ArrowT
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 -}