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