Add TH support for pattern synonyms (fixes #8761)
[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 writeTcRef (tcg_th_remote_state tcg) Nothing
930
931 runTHExp :: ForeignHValue -> TcM TH.Exp
932 runTHExp = runTH THExp
933
934 runTHPat :: ForeignHValue -> TcM TH.Pat
935 runTHPat = runTH THPat
936
937 runTHType :: ForeignHValue -> TcM TH.Type
938 runTHType = runTH THType
939
940 runTHDec :: ForeignHValue -> TcM [TH.Dec]
941 runTHDec = runTH THDec
942
943 runTH :: Binary a => THResultType -> ForeignHValue -> TcM a
944 runTH ty fhv = do
945 hsc_env <- env_top <$> getEnv
946 dflags <- getDynFlags
947 if not (gopt Opt_ExternalInterpreter dflags)
948 then do
949 -- just run it in the local TcM
950 hv <- liftIO $ wormhole dflags fhv
951 r <- runQuasi (unsafeCoerce# hv :: TH.Q a)
952 return r
953 else
954 -- run it on the server
955 withIServ hsc_env $ \i -> do
956 rstate <- getTHState i
957 loc <- TH.qLocation
958 liftIO $
959 withForeignRef rstate $ \state_hv ->
960 withForeignRef fhv $ \q_hv ->
961 writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))
962 bs <- runRemoteTH i []
963 return $! runGet get (LB.fromStrict bs)
964
965 -- | communicate with a remotely-running TH computation until it
966 -- finishes and returns a result.
967 runRemoteTH
968 :: Binary a
969 => IServ
970 -> [Messages] -- saved from nested calls to qRecover
971 -> TcM a
972 runRemoteTH iserv recovers = do
973 Msg msg <- liftIO $ readIServ iserv getMessage
974 case msg of
975 QDone -> liftIO $ readIServ iserv get
976 QException str -> liftIO $ throwIO (ErrorCall str)
977 QFail str -> fail str
978 StartRecover -> do -- Note [TH recover with -fexternal-interpreter]
979 v <- getErrsVar
980 msgs <- readTcRef v
981 writeTcRef v emptyMessages
982 runRemoteTH iserv (msgs : recovers)
983 EndRecover caught_error -> do
984 v <- getErrsVar
985 let (prev_msgs, rest) = case recovers of
986 [] -> panic "EndRecover"
987 a : b -> (a,b)
988 if caught_error
989 then writeTcRef v prev_msgs
990 else updTcRef v (unionMessages prev_msgs)
991 runRemoteTH iserv rest
992 _other -> do
993 r <- handleTHMessage msg
994 liftIO $ writeIServ iserv (put r)
995 runRemoteTH iserv recovers
996
997 {- Note [TH recover with -fexternal-interpreter]
998
999 Recover is slightly tricky to implement.
1000
1001 The meaning of "recover a b" is
1002 - Do a
1003 - If it finished successfully, then keep the messages it generated
1004 - If it failed, discard any messages it generated, and do b
1005
1006 The messages are managed by GHC in the TcM monad, whereas the
1007 exception-handling is done in the ghc-iserv process, so we have to
1008 coordinate between the two.
1009
1010 On the server:
1011 - emit a StartRecover message
1012 - run "a" inside a catch
1013 - if it finishes, emit EndRecover False
1014 - if it fails, emit EndRecover True, then run "b"
1015
1016 Back in GHC, when we receive:
1017
1018 StartRecover
1019 save the current messages and start with an empty set.
1020 EndRecover caught_error
1021 Restore the previous messages,
1022 and merge in the new messages if caught_error is false.
1023 -}
1024
1025 getTHState :: IServ -> TcM (ForeignRef (IORef QState))
1026 getTHState i = do
1027 tcg <- getGblEnv
1028 th_state <- readTcRef (tcg_th_remote_state tcg)
1029 case th_state of
1030 Just rhv -> return rhv
1031 Nothing -> do
1032 hsc_env <- env_top <$> getEnv
1033 fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH
1034 writeTcRef (tcg_th_remote_state tcg) (Just fhv)
1035 return fhv
1036
1037 wrapTHResult :: TcM a -> TcM (THResult a)
1038 wrapTHResult tcm = do
1039 e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic
1040 case e of
1041 Left e -> return (THException (show e))
1042 Right a -> return (THComplete a)
1043
1044 handleTHMessage :: Message a -> TcM a
1045 handleTHMessage msg = case msg of
1046 NewName a -> wrapTHResult $ TH.qNewName a
1047 Report b str -> wrapTHResult $ TH.qReport b str
1048 LookupName b str -> wrapTHResult $ TH.qLookupName b str
1049 Reify n -> wrapTHResult $ TH.qReify n
1050 ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
1051 ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
1052 ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
1053 ReifyAnnotations lookup tyrep ->
1054 wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
1055 ReifyModule m -> wrapTHResult $ TH.qReifyModule m
1056 AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
1057 AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
1058 IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
1059 ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
1060 _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
1061
1062 getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
1063 getAnnotationsByTypeRep th_name tyrep
1064 = do { name <- lookupThAnnLookup th_name
1065 ; topEnv <- getTopEnv
1066 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1067 ; tcg <- getGblEnv
1068 ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep
1069 ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep
1070 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1071
1072 {-
1073 ************************************************************************
1074 * *
1075 Instance Testing
1076 * *
1077 ************************************************************************
1078 -}
1079
1080 reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
1081 reifyInstances th_nm th_tys
1082 = addErrCtxt (text "In the argument of reifyInstances:"
1083 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
1084 do { loc <- getSrcSpanM
1085 ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)
1086 -- #9262 says to bring vars into scope, like in HsForAllTy case
1087 -- of rnHsTyKi
1088 ; free_vars <- extractHsTyRdrTyVars rdr_ty
1089 ; let tv_rdrs = freeKiTyVarsAllVars free_vars
1090 -- Rename to HsType Name
1091 ; ((tv_names, rn_ty), _fvs)
1092 <- bindLRdrNames tv_rdrs $ \ tv_names ->
1093 do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
1094 ; return ((tv_names, rn_ty), fvs) }
1095 ; (_tvs, ty)
1096 <- solveEqualities $
1097 tcImplicitTKBndrsType tv_names $
1098 fst <$> tcLHsType rn_ty
1099 ; ty <- zonkTcTypeToType emptyZonkEnv ty
1100 -- Substitute out the meta type variables
1101 -- In particular, the type might have kind
1102 -- variables inside it (Trac #7477)
1103
1104 ; traceTc "reifyInstances" (ppr ty $$ ppr (typeKind ty))
1105 ; case splitTyConApp_maybe ty of -- This expands any type synonyms
1106 Just (tc, tys) -- See Trac #7910
1107 | Just cls <- tyConClass_maybe tc
1108 -> do { inst_envs <- tcGetInstEnvs
1109 ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys
1110 ; traceTc "reifyInstances1" (ppr matches)
1111 ; reifyClassInstances cls (map fst matches ++ unifies) }
1112 | isOpenFamilyTyCon tc
1113 -> do { inst_envs <- tcGetFamInstEnvs
1114 ; let matches = lookupFamInstEnv inst_envs tc tys
1115 ; traceTc "reifyInstances2" (ppr matches)
1116 ; reifyFamilyInstances tc (map fim_instance matches) }
1117 _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))
1118 2 (text "is not a class constraint or type family application")) }
1119 where
1120 doc = ClassInstanceCtx
1121 bale_out msg = failWithTc msg
1122
1123 cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName)
1124 cvt loc th_ty = case convertToHsType loc th_ty of
1125 Left msg -> failWithTc msg
1126 Right ty -> return ty
1127
1128 {-
1129 ************************************************************************
1130 * *
1131 Reification
1132 * *
1133 ************************************************************************
1134 -}
1135
1136 lookupName :: Bool -- True <=> type namespace
1137 -- False <=> value namespace
1138 -> String -> TcM (Maybe TH.Name)
1139 lookupName is_type_name s
1140 = do { lcl_env <- getLocalRdrEnv
1141 ; case lookupLocalRdrEnv lcl_env rdr_name of
1142 Just n -> return (Just (reifyName n))
1143 Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name
1144 ; return (fmap reifyName mb_nm) } }
1145 where
1146 th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M'
1147
1148 occ_fs :: FastString
1149 occ_fs = mkFastString (TH.nameBase th_name)
1150
1151 occ :: OccName
1152 occ | is_type_name
1153 = if isLexCon occ_fs then mkTcOccFS occ_fs
1154 else mkTyVarOccFS occ_fs
1155 | otherwise
1156 = if isLexCon occ_fs then mkDataOccFS occ_fs
1157 else mkVarOccFS occ_fs
1158
1159 rdr_name = case TH.nameModule th_name of
1160 Nothing -> mkRdrUnqual occ
1161 Just mod -> mkRdrQual (mkModuleName mod) occ
1162
1163 getThing :: TH.Name -> TcM TcTyThing
1164 getThing th_name
1165 = do { name <- lookupThName th_name
1166 ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
1167 ; tcLookupTh name }
1168 -- ToDo: this tcLookup could fail, which would give a
1169 -- rather unhelpful error message
1170 where
1171 ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
1172 ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
1173 ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
1174 ppr_ns _ = panic "reify/ppr_ns"
1175
1176 reify :: TH.Name -> TcM TH.Info
1177 reify th_name
1178 = do { traceTc "reify 1" (text (TH.showName th_name))
1179 ; thing <- getThing th_name
1180 ; traceTc "reify 2" (ppr thing)
1181 ; reifyThing thing }
1182
1183 lookupThName :: TH.Name -> TcM Name
1184 lookupThName th_name = do
1185 mb_name <- lookupThName_maybe th_name
1186 case mb_name of
1187 Nothing -> failWithTc (notInScope th_name)
1188 Just name -> return name
1189
1190 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
1191 lookupThName_maybe th_name
1192 = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
1193 -- Pick the first that works
1194 -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
1195 ; return (listToMaybe names) }
1196 where
1197 lookup rdr_name
1198 = do { -- Repeat much of lookupOccRn, becase we want
1199 -- to report errors in a TH-relevant way
1200 ; rdr_env <- getLocalRdrEnv
1201 ; case lookupLocalRdrEnv rdr_env rdr_name of
1202 Just name -> return (Just name)
1203 Nothing -> lookupGlobalOccRn_maybe rdr_name }
1204
1205 tcLookupTh :: Name -> TcM TcTyThing
1206 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
1207 -- it gives a reify-related error message on failure, whereas in the normal
1208 -- tcLookup, failure is a bug.
1209 tcLookupTh name
1210 = do { (gbl_env, lcl_env) <- getEnvs
1211 ; case lookupNameEnv (tcl_env lcl_env) name of {
1212 Just thing -> return thing;
1213 Nothing ->
1214
1215 case lookupNameEnv (tcg_type_env gbl_env) name of {
1216 Just thing -> return (AGlobal thing);
1217 Nothing ->
1218
1219 if nameIsLocalOrFrom (tcg_mod gbl_env) name
1220 then -- It's defined in this module
1221 failWithTc (notInEnv name)
1222
1223 else
1224 do { mb_thing <- tcLookupImported_maybe name
1225 ; case mb_thing of
1226 Succeeded thing -> return (AGlobal thing)
1227 Failed msg -> failWithTc msg
1228 }}}}
1229
1230 notInScope :: TH.Name -> SDoc
1231 notInScope th_name = quotes (text (TH.pprint th_name)) <+>
1232 text "is not in scope at a reify"
1233 -- Ugh! Rather an indirect way to display the name
1234
1235 notInEnv :: Name -> SDoc
1236 notInEnv name = quotes (ppr name) <+>
1237 text "is not in the type environment at a reify"
1238
1239 ------------------------------
1240 reifyRoles :: TH.Name -> TcM [TH.Role]
1241 reifyRoles th_name
1242 = do { thing <- getThing th_name
1243 ; case thing of
1244 AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
1245 _ -> failWithTc (text "No roles associated with" <+> (ppr thing))
1246 }
1247 where
1248 reify_role Nominal = TH.NominalR
1249 reify_role Representational = TH.RepresentationalR
1250 reify_role Phantom = TH.PhantomR
1251
1252 ------------------------------
1253 reifyThing :: TcTyThing -> TcM TH.Info
1254 -- The only reason this is monadic is for error reporting,
1255 -- which in turn is mainly for the case when TH can't express
1256 -- some random GHC extension
1257
1258 reifyThing (AGlobal (AnId id))
1259 = do { ty <- reifyType (idType id)
1260 ; let v = reifyName id
1261 ; case idDetails id of
1262 ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))
1263 RecSelId{sel_tycon=RecSelData tc}
1264 -> return (TH.VarI (reifySelector id tc) ty Nothing)
1265 _ -> return (TH.VarI v ty Nothing)
1266 }
1267
1268 reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
1269 reifyThing (AGlobal (AConLike (RealDataCon dc)))
1270 = do { let name = dataConName dc
1271 ; ty <- reifyType (idType (dataConWrapId dc))
1272 ; return (TH.DataConI (reifyName name) ty
1273 (reifyName (dataConOrigTyCon dc)))
1274 }
1275
1276 reifyThing (AGlobal (AConLike (PatSynCon ps)))
1277 = do { let name = reifyName ps
1278 ; ty <- reifyPatSynType (patSynSig ps)
1279 ; return (TH.PatSynI name ty) }
1280
1281 reifyThing (ATcId {tct_id = id})
1282 = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
1283 -- though it may be incomplete
1284 ; ty2 <- reifyType ty1
1285 ; return (TH.VarI (reifyName id) ty2 Nothing) }
1286
1287 reifyThing (ATyVar tv tv1)
1288 = do { ty1 <- zonkTcTyVar tv1
1289 ; ty2 <- reifyType ty1
1290 ; return (TH.TyVarI (reifyName tv) ty2) }
1291
1292 reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
1293
1294 -------------------------------------------
1295 reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
1296 reifyAxBranch fam_tc (CoAxBranch { cab_lhs = args, cab_rhs = rhs })
1297 -- remove kind patterns (#8884)
1298 = do { args' <- mapM reifyType (filterOutInvisibleTypes fam_tc args)
1299 ; rhs' <- reifyType rhs
1300 ; return (TH.TySynEqn args' rhs') }
1301
1302 reifyTyCon :: TyCon -> TcM TH.Info
1303 reifyTyCon tc
1304 | Just cls <- tyConClass_maybe tc
1305 = reifyClass cls
1306
1307 | isFunTyCon tc
1308 = return (TH.PrimTyConI (reifyName tc) 2 False)
1309
1310 | isPrimTyCon tc
1311 = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnliftedTyCon tc))
1312
1313 | isTypeFamilyTyCon tc
1314 = do { let tvs = tyConTyVars tc
1315 res_kind = tyConResKind tc
1316 resVar = famTcResVar tc
1317
1318 ; kind' <- reifyKind res_kind
1319 ; let (resultSig, injectivity) =
1320 case resVar of
1321 Nothing -> (TH.KindSig kind', Nothing)
1322 Just name ->
1323 let thName = reifyName name
1324 injAnnot = familyTyConInjectivityInfo tc
1325 sig = TH.TyVarSig (TH.KindedTV thName kind')
1326 inj = case injAnnot of
1327 NotInjective -> Nothing
1328 Injective ms ->
1329 Just (TH.InjectivityAnn thName injRHS)
1330 where
1331 injRHS = map (reifyName . tyVarName)
1332 (filterByList ms tvs)
1333 in (sig, inj)
1334 ; tvs' <- reifyTyVars tvs (Just tc)
1335 ; let tfHead =
1336 TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity
1337 ; if isOpenTypeFamilyTyCon tc
1338 then do { fam_envs <- tcGetFamInstEnvs
1339 ; instances <- reifyFamilyInstances tc
1340 (familyInstances fam_envs tc)
1341 ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) }
1342 else do { eqns <-
1343 case isClosedSynFamilyTyConWithAxiom_maybe tc of
1344 Just ax -> mapM (reifyAxBranch tc) $
1345 fromBranches $ coAxiomBranches ax
1346 Nothing -> return []
1347 ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns)
1348 []) } }
1349
1350 | isDataFamilyTyCon tc
1351 = do { let tvs = tyConTyVars tc
1352 res_kind = tyConResKind tc
1353
1354 ; kind' <- fmap Just (reifyKind res_kind)
1355
1356 ; tvs' <- reifyTyVars tvs (Just tc)
1357 ; fam_envs <- tcGetFamInstEnvs
1358 ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)
1359 ; return (TH.FamilyI
1360 (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }
1361
1362 | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym
1363 = do { rhs' <- reifyType rhs
1364 ; tvs' <- reifyTyVars tvs (Just tc)
1365 ; return (TH.TyConI
1366 (TH.TySynD (reifyName tc) tvs' rhs'))
1367 }
1368
1369 | otherwise
1370 = do { cxt <- reifyCxt (tyConStupidTheta tc)
1371 ; let tvs = tyConTyVars tc
1372 dataCons = tyConDataCons tc
1373 -- see Note [Reifying GADT data constructors]
1374 isGadt = any (not . null . dataConEqSpec) dataCons
1375 ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
1376 ; r_tvs <- reifyTyVars tvs (Just tc)
1377 ; let name = reifyName tc
1378 deriv = [] -- Don't know about deriving
1379 decl | isNewTyCon tc =
1380 TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv
1381 | otherwise =
1382 TH.DataD cxt name r_tvs Nothing cons deriv
1383 ; return (TH.TyConI decl) }
1384
1385 reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con
1386 -- For GADTs etc, see Note [Reifying GADT data constructors]
1387 reifyDataCon isGadtDataCon tys dc
1388 = do { let -- used for H98 data constructors
1389 (ex_tvs, theta, arg_tys)
1390 = dataConInstSig dc tys
1391 -- used for GADTs data constructors
1392 (g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, g_res_ty)
1393 = dataConFullSig dc
1394 (srcUnpks, srcStricts)
1395 = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
1396 dcdBangs = zipWith TH.Bang srcUnpks srcStricts
1397 fields = dataConFieldLabels dc
1398 name = reifyName dc
1399 -- Universal tvs present in eq_spec need to be filtered out, as
1400 -- they will not appear anywhere in the type.
1401 eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec)
1402 g_unsbst_univ_tvs = filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs
1403
1404 ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
1405
1406 ; main_con <-
1407 if | not (null fields) && not isGadtDataCon ->
1408 return $ TH.RecC name (zip3 (map reifyFieldLabel fields)
1409 dcdBangs r_arg_tys)
1410 | not (null fields) -> do
1411 { res_ty <- reifyType g_res_ty
1412 ; return $ TH.RecGadtC [name]
1413 (zip3 (map (reifyName . flSelector) fields)
1414 dcdBangs r_arg_tys) res_ty }
1415 -- We need to check not isGadtDataCon here because GADT
1416 -- constructors can be declared infix.
1417 -- See Note [Infix GADT constructors] in TcTyClsDecls.
1418 | dataConIsInfix dc && not isGadtDataCon ->
1419 ASSERT( length arg_tys == 2 ) do
1420 { let [r_a1, r_a2] = r_arg_tys
1421 [s1, s2] = dcdBangs
1422 ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
1423 | isGadtDataCon -> do
1424 { res_ty <- reifyType g_res_ty
1425 ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }
1426 | otherwise ->
1427 return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
1428
1429 ; let (ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs
1430 , g_theta )
1431 | otherwise = ( ex_tvs, theta )
1432 ret_con | null ex_tvs' && null theta' = return main_con
1433 | otherwise = do
1434 { cxt <- reifyCxt theta'
1435 ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing
1436 ; return (TH.ForallC ex_tvs'' cxt main_con) }
1437 ; ASSERT( length arg_tys == length dcdBangs )
1438 ret_con }
1439
1440 -- Note [Reifying GADT data constructors]
1441 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1442 -- At this point in the compilation pipeline we have no way of telling whether a
1443 -- data type was declared as a H98 data type or as a GADT. We have to rely on
1444 -- heuristics here. We look at dcEqSpec field of all data constructors in a
1445 -- data type declaration. If at least one data constructor has non-empty
1446 -- dcEqSpec this means that the data type must have been declared as a GADT.
1447 -- Consider these declarations:
1448 --
1449 -- data T a where
1450 -- MkT :: forall a. (a ~ Int) => T a
1451 --
1452 -- data T a where
1453 -- MkT :: T Int
1454 --
1455 -- First declaration will be reified as a GADT. Second declaration will be
1456 -- reified as a normal H98 data type declaration.
1457
1458 ------------------------------
1459 reifyClass :: Class -> TcM TH.Info
1460 reifyClass cls
1461 = do { cxt <- reifyCxt theta
1462 ; inst_envs <- tcGetInstEnvs
1463 ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
1464 ; assocTys <- concatMapM reifyAT ats
1465 ; ops <- concatMapM reify_op op_stuff
1466 ; tvs' <- reifyTyVars tvs (Just $ classTyCon cls)
1467 ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
1468 ; return (TH.ClassI dec insts) }
1469 where
1470 (tvs, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
1471 fds' = map reifyFunDep fds
1472 reify_op (op, def_meth)
1473 = do { ty <- reifyType (idType op)
1474 ; let nm' = reifyName op
1475 ; case def_meth of
1476 Just (_, GenericDM gdm_ty) ->
1477 do { gdm_ty' <- reifyType gdm_ty
1478 ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty'] }
1479 _ -> return [TH.SigD nm' ty] }
1480
1481 reifyAT :: ClassATItem -> TcM [TH.Dec]
1482 reifyAT (ATI tycon def) = do
1483 tycon' <- reifyTyCon tycon
1484 case tycon' of
1485 TH.FamilyI dec _ -> do
1486 let (tyName, tyArgs) = tfNames dec
1487 (dec :) <$> maybe (return [])
1488 (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
1489 def
1490 _ -> pprPanic "reifyAT" (text (show tycon'))
1491
1492 reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
1493 reifyDefImpl n args ty =
1494 TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty
1495
1496 tfNames :: TH.Dec -> (TH.Name, [TH.Name])
1497 tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
1498 = (n, map bndrName args)
1499 tfNames d = pprPanic "tfNames" (text (show d))
1500
1501 bndrName :: TH.TyVarBndr -> TH.Name
1502 bndrName (TH.PlainTV n) = n
1503 bndrName (TH.KindedTV n _) = n
1504
1505 ------------------------------
1506 -- | Annotate (with TH.SigT) a type if the first parameter is True
1507 -- and if the type contains a free variable.
1508 -- This is used to annotate type patterns for poly-kinded tyvars in
1509 -- reifying class and type instances. See #8953 and th/T8953.
1510 annotThType :: Bool -- True <=> annotate
1511 -> TyCoRep.Type -> TH.Type -> TcM TH.Type
1512 -- tiny optimization: if the type is annotated, don't annotate again.
1513 annotThType _ _ th_ty@(TH.SigT {}) = return th_ty
1514 annotThType True ty th_ty
1515 | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
1516 = do { let ki = typeKind ty
1517 ; th_ki <- reifyKind ki
1518 ; return (TH.SigT th_ty th_ki) }
1519 annotThType _ _ th_ty = return th_ty
1520
1521 -- | For every type variable in the input,
1522 -- report whether or not the tv is poly-kinded. This is used to eventually
1523 -- feed into 'annotThType'.
1524 mkIsPolyTvs :: [TyVar] -> [Bool]
1525 mkIsPolyTvs = map is_poly_tv
1526 where
1527 is_poly_tv tv = not $
1528 isEmptyVarSet $
1529 filterVarSet isTyVar $
1530 tyCoVarsOfType $
1531 tyVarKind tv
1532
1533 ------------------------------
1534 reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
1535 reifyClassInstances cls insts
1536 = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
1537 where
1538 tvs = filterOutInvisibleTyVars (classTyCon cls) (classTyVars cls)
1539
1540 reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1541 -- includes only *visible* tvs
1542 -> ClsInst -> TcM TH.Dec
1543 reifyClassInstance is_poly_tvs i
1544 = do { cxt <- reifyCxt theta
1545 ; let vis_types = filterOutInvisibleTypes cls_tc types
1546 ; thtypes <- reifyTypes vis_types
1547 ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
1548 ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
1549 ; return $ (TH.InstanceD over cxt head_ty []) }
1550 where
1551 (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
1552 cls_tc = classTyCon cls
1553 dfun = instanceDFunId i
1554 over = case overlapMode (is_flag i) of
1555 NoOverlap _ -> Nothing
1556 Overlappable _ -> Just TH.Overlappable
1557 Overlapping _ -> Just TH.Overlapping
1558 Overlaps _ -> Just TH.Overlaps
1559 Incoherent _ -> Just TH.Incoherent
1560
1561 ------------------------------
1562 reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
1563 reifyFamilyInstances fam_tc fam_insts
1564 = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
1565 where
1566 fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
1567
1568 reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
1569 -- includes only *visible* tvs
1570 -> FamInst -> TcM TH.Dec
1571 reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
1572 , fi_fam = fam
1573 , fi_tys = lhs
1574 , fi_rhs = rhs })
1575 = case flavor of
1576 SynFamilyInst ->
1577 -- remove kind patterns (#8884)
1578 do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
1579 ; th_lhs <- reifyTypes lhs_types_only
1580 ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
1581 th_lhs
1582 ; th_rhs <- reifyType rhs
1583 ; return (TH.TySynInstD (reifyName fam)
1584 (TH.TySynEqn annot_th_lhs th_rhs)) }
1585
1586 DataFamilyInst rep_tc ->
1587 do { let tvs = tyConTyVars rep_tc
1588 fam' = reifyName fam
1589
1590 -- eta-expand lhs types, because sometimes data/newtype
1591 -- instances are eta-reduced; See Trac #9692
1592 -- See Note [Eta reduction for data family axioms]
1593 -- in TcInstDcls
1594 (_rep_tc, rep_tc_args) = splitTyConApp rhs
1595 etad_tyvars = dropList rep_tc_args tvs
1596 eta_expanded_lhs = lhs `chkAppend` mkTyVarTys etad_tyvars
1597 dataCons = tyConDataCons rep_tc
1598 -- see Note [Reifying GADT data constructors]
1599 isGadt = any (not . null . dataConEqSpec) dataCons
1600 ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
1601 ; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs
1602 ; th_tys <- reifyTypes types_only
1603 ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
1604 ; return $
1605 if isNewTyCon rep_tc
1606 then TH.NewtypeInstD [] fam' annot_th_tys Nothing (head cons) []
1607 else TH.DataInstD [] fam' annot_th_tys Nothing cons []
1608 }
1609 where
1610 fam_tc = famInstTyCon inst
1611
1612 ------------------------------
1613 reifyType :: TyCoRep.Type -> TcM TH.Type
1614 -- Monadic only because of failure
1615 reifyType ty@(ForAllTy (Named _ _) _) = reify_for_all ty
1616 reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) }
1617 reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
1618 reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
1619 reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
1620 reifyType ty@(ForAllTy (Anon t1) t2)
1621 | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
1622 | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
1623 reifyType ty@(CastTy {}) = noTH (sLit "kind casts") (ppr ty)
1624 reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)
1625
1626 reify_for_all :: TyCoRep.Type -> TcM TH.Type
1627 reify_for_all ty
1628 = do { cxt' <- reifyCxt cxt;
1629 ; tau' <- reifyType tau
1630 ; tvs' <- reifyTyVars tvs Nothing
1631 ; return (TH.ForallT tvs' cxt' tau') }
1632 where
1633 (tvs, cxt, tau) = tcSplitSigmaTy ty
1634
1635 reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
1636 reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
1637 reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
1638
1639 reifyTypes :: [Type] -> TcM [TH.Type]
1640 reifyTypes = mapM reifyType
1641
1642 reifyPatSynType
1643 :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type
1644 -- reifies a pattern synonym's type and returns its *complete* type
1645 -- signature; see NOTE [Pattern synonym signatures and Template
1646 -- Haskell]
1647 reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
1648 = do { univTyVars' <- reifyTyVars univTyVars Nothing
1649 ; req' <- reifyCxt req
1650 ; exTyVars' <- reifyTyVars exTyVars Nothing
1651 ; prov' <- reifyCxt prov
1652 ; tau' <- reifyType (mkFunTys argTys resTy)
1653 ; return $ TH.ForallT univTyVars' req'
1654 $ TH.ForallT exTyVars' prov' tau' }
1655
1656 reifyKind :: Kind -> TcM TH.Kind
1657 reifyKind ki
1658 = do { let (kis, ki') = splitFunTys ki
1659 ; ki'_rep <- reifyNonArrowKind ki'
1660 ; kis_rep <- mapM reifyKind kis
1661 ; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) }
1662 where
1663 reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT
1664 | isConstraintKind k = return TH.ConstraintT
1665 reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v))
1666 reifyNonArrowKind (ForAllTy _ k) = reifyKind k
1667 reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis
1668 reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1
1669 ; k2' <- reifyKind k2
1670 ; return (TH.AppT k1' k2')
1671 }
1672 reifyNonArrowKind k = noTH (sLit "this kind") (ppr k)
1673
1674 reify_kc_app :: TyCon -> [TyCoRep.Kind] -> TcM TH.Kind
1675 reify_kc_app kc kis
1676 = fmap (mkThAppTs r_kc) (mapM reifyKind vis_kis)
1677 where
1678 r_kc | isTupleTyCon kc = TH.TupleT (tyConArity kc)
1679 | kc `hasKey` listTyConKey = TH.ListT
1680 | otherwise = TH.ConT (reifyName kc)
1681
1682 vis_kis = filterOutInvisibleTypes kc kis
1683
1684 reifyCxt :: [PredType] -> TcM [TH.Pred]
1685 reifyCxt = mapM reifyPred
1686
1687 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
1688 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
1689
1690 reifyTyVars :: [TyVar]
1691 -> Maybe TyCon -- the tycon if the tycovars are from a tycon.
1692 -- Used to detect which tvs are implicit.
1693 -> TcM [TH.TyVarBndr]
1694 reifyTyVars tvs m_tc = mapM reify_tv tvs'
1695 where
1696 tvs' = case m_tc of
1697 Just tc -> filterOutInvisibleTyVars tc tvs
1698 Nothing -> tvs
1699
1700 -- even if the kind is *, we need to include a kind annotation,
1701 -- in case a poly-kind would be inferred without the annotation.
1702 -- See #8953 or test th/T8953
1703 reify_tv tv = TH.KindedTV name <$> reifyKind kind
1704 where
1705 kind = tyVarKind tv
1706 name = reifyName tv
1707
1708 {-
1709 Note [Kind annotations on TyConApps]
1710 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1711 A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.
1712 For example:
1713
1714 type family F a :: k
1715 type instance F Int = (Proxy :: * -> *)
1716 type instance F Bool = (Proxy :: (* -> *) -> *)
1717
1718 It's hard to figure out where these annotations should appear, so we do this:
1719 Suppose the tycon is applied to n arguments. We strip off the first n
1720 arguments of the tycon's kind. If there are any variables left in the result
1721 kind, we put on a kind annotation. But we must be slightly careful: it's
1722 possible that the tycon's kind will have fewer than n arguments, in the case
1723 that the concrete application instantiates a result kind variable with an
1724 arrow kind. So, if we run out of arguments, we conservatively put on a kind
1725 annotation anyway. This should be a rare case, indeed. Here is an example:
1726
1727 data T1 :: k1 -> k2 -> *
1728 data T2 :: k1 -> k2 -> *
1729
1730 type family G (a :: k) :: k
1731 type instance G T1 = T2
1732
1733 type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above
1734
1735 Here G's kind is (forall k. k -> k), and the desugared RHS of that last
1736 instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
1737 the algorithm above, there are 3 arguments to G so we should peel off 3
1738 arguments in G's kind. But G's kind has only two arguments. This is the
1739 rare special case, and we conservatively choose to put the annotation
1740 in.
1741
1742 See #8953 and test th/T8953.
1743 -}
1744
1745 reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
1746 reify_tc_app tc tys
1747 = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
1748 ; maybe_sig_t (mkThAppTs r_tc tys') }
1749 where
1750 arity = tyConArity tc
1751 tc_binders = tyConBinders tc
1752 tc_res_kind = tyConResKind tc
1753
1754 r_tc | isTupleTyCon tc = if isPromotedDataCon tc
1755 then TH.PromotedTupleT arity
1756 else TH.TupleT arity
1757 | tc `hasKey` listTyConKey = TH.ListT
1758 | tc `hasKey` nilDataConKey = TH.PromotedNilT
1759 | tc `hasKey` consDataConKey = TH.PromotedConsT
1760 | tc `hasKey` heqTyConKey = TH.EqualityT
1761 | tc `hasKey` eqPrimTyConKey = TH.EqualityT
1762 | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
1763 | otherwise = TH.ConT (reifyName tc)
1764
1765 -- See Note [Kind annotations on TyConApps]
1766 maybe_sig_t th_type
1767 | needs_kind_sig
1768 = do { let full_kind = typeKind (mkTyConApp tc tys)
1769 ; th_full_kind <- reifyKind full_kind
1770 ; return (TH.SigT th_type th_full_kind) }
1771 | otherwise
1772 = return th_type
1773
1774 needs_kind_sig
1775 | GT <- compareLength tys tc_binders
1776 , tcIsTyVarTy tc_res_kind
1777 = True
1778 | otherwise
1779 = not $
1780 isEmptyVarSet $
1781 filterVarSet isTyVar $
1782 tyCoVarsOfType $
1783 mkForAllTys (dropList tys tc_binders) tc_res_kind
1784
1785 reifyPred :: TyCoRep.PredType -> TcM TH.Pred
1786 reifyPred ty
1787 -- We could reify the invisible paramter as a class but it seems
1788 -- nicer to support them properly...
1789 | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
1790 | otherwise = reifyType ty
1791
1792 ------------------------------
1793 reifyName :: NamedThing n => n -> TH.Name
1794 reifyName thing
1795 | isExternalName name = mk_varg pkg_str mod_str occ_str
1796 | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
1797 -- Many of the things we reify have local bindings, and
1798 -- NameL's aren't supposed to appear in binding positions, so
1799 -- we use NameU. When/if we start to reify nested things, that
1800 -- have free variables, we may need to generate NameL's for them.
1801 where
1802 name = getName thing
1803 mod = ASSERT( isExternalName name ) nameModule name
1804 pkg_str = unitIdString (moduleUnitId mod)
1805 mod_str = moduleNameString (moduleName mod)
1806 occ_str = occNameString occ
1807 occ = nameOccName name
1808 mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
1809 | OccName.isVarOcc occ = TH.mkNameG_v
1810 | OccName.isTcOcc occ = TH.mkNameG_tc
1811 | otherwise = pprPanic "reifyName" (ppr name)
1812
1813 -- See Note [Reifying field labels]
1814 reifyFieldLabel :: FieldLabel -> TH.Name
1815 reifyFieldLabel fl
1816 | flIsOverloaded fl
1817 = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))
1818 | otherwise = TH.mkNameG_v pkg_str mod_str occ_str
1819 where
1820 name = flSelector fl
1821 mod = ASSERT( isExternalName name ) nameModule name
1822 pkg_str = unitIdString (moduleUnitId mod)
1823 mod_str = moduleNameString (moduleName mod)
1824 occ_str = unpackFS (flLabel fl)
1825
1826 reifySelector :: Id -> TyCon -> TH.Name
1827 reifySelector id tc
1828 = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of
1829 Just fl -> reifyFieldLabel fl
1830 Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
1831
1832 ------------------------------
1833 reifyFixity :: Name -> TcM (Maybe TH.Fixity)
1834 reifyFixity name
1835 = do { (found, fix) <- lookupFixityRn_help name
1836 ; return (if found then Just (conv_fix fix) else Nothing) }
1837 where
1838 conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d)
1839 conv_dir BasicTypes.InfixR = TH.InfixR
1840 conv_dir BasicTypes.InfixL = TH.InfixL
1841 conv_dir BasicTypes.InfixN = TH.InfixN
1842
1843 reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness
1844 reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness
1845 reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack
1846 reifyUnpackedness SrcUnpack = TH.SourceUnpack
1847
1848 reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness
1849 reifyStrictness NoSrcStrict = TH.NoSourceStrictness
1850 reifyStrictness SrcStrict = TH.SourceStrict
1851 reifyStrictness SrcLazy = TH.SourceLazy
1852
1853 reifySourceBang :: DataCon.HsSrcBang
1854 -> (TH.SourceUnpackedness, TH.SourceStrictness)
1855 reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)
1856
1857 reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness
1858 reifyDecidedStrictness HsLazy = TH.DecidedLazy
1859 reifyDecidedStrictness HsStrict = TH.DecidedStrict
1860 reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack
1861
1862 ------------------------------
1863 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
1864 lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
1865 lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
1866 = return $ ModuleTarget $
1867 mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
1868
1869 reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
1870 reifyAnnotations th_name
1871 = do { name <- lookupThAnnLookup th_name
1872 ; topEnv <- getTopEnv
1873 ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
1874 ; tcg <- getGblEnv
1875 ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
1876 ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
1877 ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
1878
1879 ------------------------------
1880 modToTHMod :: Module -> TH.Module
1881 modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId m)
1882 (TH.ModName $ moduleNameString $ moduleName m)
1883
1884 reifyModule :: TH.Module -> TcM TH.ModuleInfo
1885 reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
1886 this_mod <- getModule
1887 let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)
1888 if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
1889 where
1890 reifyThisModule = do
1891 usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
1892 return $ TH.ModuleInfo usages
1893
1894 reifyFromIface reifMod = do
1895 iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod
1896 let usages = [modToTHMod m | usage <- mi_usages iface,
1897 Just m <- [usageToModule (moduleUnitId reifMod) usage] ]
1898 return $ TH.ModuleInfo usages
1899
1900 usageToModule :: UnitId -> Usage -> Maybe Module
1901 usageToModule _ (UsageFile {}) = Nothing
1902 usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
1903 usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
1904
1905 ------------------------------
1906 mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
1907 mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys
1908
1909 noTH :: LitString -> SDoc -> TcM a
1910 noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+>
1911 text "in Template Haskell:",
1912 nest 2 d])
1913
1914 ppr_th :: TH.Ppr a => a -> SDoc
1915 ppr_th x = text (TH.pprint x)
1916
1917 {-
1918 Note [Reifying field labels]
1919 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1920 When reifying a datatype declared with DuplicateRecordFields enabled, we want
1921 the reified names of the fields to be labels rather than selector functions.
1922 That is, we want (reify ''T) and (reify 'foo) to produce
1923
1924 data T = MkT { foo :: Int }
1925 foo :: T -> Int
1926
1927 rather than
1928
1929 data T = MkT { $sel:foo:MkT :: Int }
1930 $sel:foo:MkT :: T -> Int
1931
1932 because otherwise TH code that uses the field names as strings will silently do
1933 the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather
1934 than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the
1935 environment, NameG can't be used to represent such fields. Instead,
1936 reifyFieldLabel uses NameQ.
1937
1938 However, this means that extracting the field name from the output of reify, and
1939 trying to reify it again, may fail with an ambiguity error if there are multiple
1940 such fields defined in the module (see the test case
1941 overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to
1942 the TH AST to make it able to represent duplicate record fields.
1943 -}
1944
1945 #endif /* GHCI */