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