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