mirrored from https://gitlab.haskell.org/ghc/ghc.git
-
Notifications
You must be signed in to change notification settings - Fork 705
/
TcSplice.lhs
1631 lines (1372 loc) · 63.7 KB
/
TcSplice.lhs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
TcSplice: Template Haskell splices
\begin{code}
module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
tcTopSpliceExpr,
lookupThName_maybe,
runQuasiQuoteExpr, runQuasiQuotePat,
runQuasiQuoteDecl, runQuasiQuoteType,
runAnnotation,
runMetaE, runMetaP, runMetaT, runMetaD ) where
#include "HsVersions.h"
import HscMain
-- These imports are the reason that TcSplice
-- is very high up the module hierarchy
import HsSyn
import Convert
import RnExpr
import RnEnv
import RdrName
import RnTypes
import TcExpr
import TcHsSyn
import TcSimplify
import TcUnify
import Type
import Kind
import TcType
import TcEnv
import TcMType
import TcHsType
import TcIface
import TypeRep
import FamInst
import FamInstEnv
import InstEnv
import Name
import NameEnv
import NameSet
import PrelNames
import HscTypes
import OccName
import Var
import Module
import Annotations
import TcRnMonad
import Class
import Inst
import TyCon
import DataCon
import TcEvidence( TcEvBinds(..) )
import Id
import IdInfo
import DsMeta
import DsExpr
import DsMonad hiding (Splice)
import Serialized
import ErrUtils
import SrcLoc
import Outputable
import Util
import Data.List ( mapAccumL )
import Pair
import Unique
import Data.Maybe
import BasicTypes
import DynFlags
import Panic
import FastString
import Control.Monad ( when )
import qualified Language.Haskell.TH as TH
-- THSyntax gives access to internal functions and data types
import qualified Language.Haskell.TH.Syntax as TH
#ifdef GHCI
-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
import GHC.Desugar ( AnnotationWrapper(..) )
#endif
import GHC.Exts ( unsafeCoerce# )
\end{code}
Note [How top-level splices are handled]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Top-level splices (those not inside a [| .. |] quotation bracket) are handled
very straightforwardly:
1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
2. runMetaT: desugar, compile, run it, and convert result back to
HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,
HsExpr RdrName etc)
3. treat the result as if that's what you saw in the first place
e.g for HsType, rename and kind-check
for HsExpr, rename and type-check
(The last step is different for decls, becuase they can *only* be
top-level: we return the result of step 2.)
Note [How brackets and nested splices are handled]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Nested splices (those inside a [| .. |] quotation bracket), are treated
quite differently.
* After typechecking, the bracket [| |] carries
a) A mutable list of PendingSplice
type PendingSplice = (Name, LHsExpr Id)
b) The quoted expression e, *renamed*: (HsExpr Name)
The expression e has been typechecked, but the result of
that typechecking is discarded.
* The brakcet is desugared by DsMeta.dsBracket. It
a) Extends the ds_meta environment with the PendingSplices
attached to the bracket
b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
run, will produce a suitable TH expression/type/decl. This
is why we leave the *renamed* expression attached to the bracket:
the quoted expression should not be decorated with all the goop
added by the type checker
* Each splice carries a unique Name, called a "splice point", thus
${n}(e). The name is initialised to an (Unqual "splice") when the
splice is created; the renamer gives it a unique.
* When the type checker type-checks a nested splice ${n}(e), it
- typechecks e
- adds the typechecked expression (of type (HsExpr Id))
as a pending splice to the enclosing bracket
- returns something non-committal
Eg for [| f ${n}(g x) |], the typechecker
- attaches the typechecked term (g x) to the pending splices for n
in the outer bracket
- returns a non-committal type \alpha.
Remember that the bracket discards the typechecked term altogether
* When DsMeta (used to desugar the body of the bracket) comes across
a splice, it looks up the splice's Name, n, in the ds_meta envt,
to find an (HsExpr Id) that should be substituted for the splice;
it just desugars it to get a CoreExpr (DsMeta.repSplice).
Example:
Source: f = [| Just $(g 3) |]
The [| |] part is a HsBracket
Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
The [| |] part is a HsBracketOut, containing *renamed*
(not typechecked) expression
The "s7" is the "splice point"; the (g Int 3) part
is a typechecked expression
Desugared: f = do { s7 <- g Int 3
; return (ConE "Data.Maybe.Just" s7) }
Note [Template Haskell state diagram]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here are the ThStages, s, their corresponding level numbers
(the result of (thLevel s)), and their state transitions.
----------- $ ------------ $
| Comp | ---------> | Splice | -----|
| 1 | | 0 | <----|
----------- ------------
^ | ^ |
$ | | [||] $ | | [||]
| v | v
-------------- ----------------
| Brack Comp | | Brack Splice |
| 2 | | 1 |
-------------- ----------------
* Normal top-level declarations start in state Comp
(which has level 1).
Annotations start in state Splice, since they are
treated very like a splice (only without a '$')
* Code compiled in state Splice (and only such code)
will be *run at compile time*, with the result replacing
the splice
* The original paper used level -1 instead of 0, etc.
* The original paper did not allow a splice within a
splice, but there is no reason not to. This is the
$ transition in the top right.
Note [Template Haskell levels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Imported things are impLevel (= 0)
* In GHCi, variables bound by a previous command are treated
as impLevel, because we have bytecode for them.
* Variables are bound at the "current level"
* The current level starts off at outerLevel (= 1)
* The level is decremented by splicing $(..)
incremented by brackets [| |]
incremented by name-quoting 'f
When a variable is used, we compare
bind: binding level, and
use: current level at usage site
Generally
bind > use Always error (bound later than used)
[| \x -> $(f x) |]
bind = use Always OK (bound same stage as used)
[| \x -> $(f [| x |]) |]
bind < use Inside brackets, it depends
Inside splice, OK
Inside neither, OK
For (bind < use) inside brackets, there are three cases:
- Imported things OK f = [| map |]
- Top-level things OK g = [| f |]
- Non-top-level Only if there is a liftable instance
h = \(x:Int) -> [| x |]
See Note [What is a top-level Id?]
Note [Quoting names]
~~~~~~~~~~~~~~~~~~~~
A quoted name 'n is a bit like a quoted expression [| n |], except that we
have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing
the use-level to account for the brackets, the cases are:
bind > use Error
bind = use OK
bind < use
Imported things OK
Top-level things OK
Non-top-level Error
See Note [What is a top-level Id?] in TcEnv. Examples:
f 'map -- OK; also for top-level defns of this module
\x. f 'x -- Not ok (whereas \x. f [| x |] might have been ok, by
-- cross-stage lifting
\y. [| \x. $(f 'y) |] -- Not ok (same reason)
[| \x. $(f 'x) |] -- OK
Note [What is a top-level Id?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the level-control criteria above, we need to know what a "top level Id" is.
There are three kinds:
* Imported from another module (GlobalId, ExternalName)
* Bound at the top level of this module (ExternalName)
* In GHCi, bound by a previous stmt (GlobalId)
It's strange that there is no one criterion tht picks out all three, but that's
how it is right now. (The obvious thing is to give an ExternalName to GHCi Ids
bound in an earlier Stmt, but what module would you choose? See
Note [Interactively-bound Ids in GHCi] in TcRnDriver.)
The predicate we use is TcEnv.thTopLevelId.
%************************************************************************
%* *
\subsection{Main interface + stubs for the non-GHCI case
%* *
%************************************************************************
\begin{code}
tcBracket :: HsBracket Name -> [PendingSplice] -> TcRhoType -> TcM (HsExpr TcId)
tcSpliceDecls :: HsSplice Name -> TcM [LHsDecl RdrName]
tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
tcSplicePat :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind)
-- None of these functions add constraints to the LIE
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName)
runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)
runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
#ifndef GHCI
tcBracket x _ _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
tcSplicePat e = pprPanic "Cant do tcSplicePat without GHCi" (ppr e)
tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
tcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
runQuasiQuoteType q = pprPanic "Cant do runQuasiQuoteType without GHCi" (ppr q)
runQuasiQuoteDecl q = pprPanic "Cant do runQuasiQuoteDecl without GHCi" (ppr q)
runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
#else
\end{code}
%************************************************************************
%* *
\subsection{Quoting an expression}
%* *
%************************************************************************
\begin{code}
-- See Note [How brackets and nested splices are handled]
tcBracket brack ps res_ty
= addErrCtxt (quotationCtxtDoc brack) $
do { cur_stage <- getStage
-- Check for nested brackets
; case cur_stage of
{ Splice True -> checkTc (isTypedBracket brack) illegalUntypedBracket
; Splice False -> checkTc (not (isTypedBracket brack)) illegalTypedBracket
; Comp -> return ()
; Brack {} -> failWithTc illegalBracket
}
-- Brackets are desugared to code that mentions the TH package
; recordThUse
-- Typecheck expr to make sure it is valid,
-- but throw away the results. We'll type check
-- it again when we actually use it.
; ps_ref <- newMutVar []
; lie_var <- getConstraintVar
; let brack_stage = Brack (isTypedBracket brack) cur_stage ps_ref lie_var
; setStage brack_stage $
tc_bracket brack ps_ref
}
where
tcUntypedBracket :: HsBracket Name -> TcM TcType
tcUntypedBracket (VarBr _ _) = -- Result type is Var (not Q-monadic)
tcMetaTy nameTyConName
tcUntypedBracket (ExpBr _) = -- Result type is ExpQ (= Q Exp)
tcMetaTy expQTyConName
tcUntypedBracket (TypBr _) = -- Result type is Type (= Q Typ)
tcMetaTy typeQTyConName
tcUntypedBracket (DecBrG _) = -- Result type is Q [Dec]
tcMetaTy decsQTyConName
tcUntypedBracket (PatBr _) = -- Result type is PatQ (= Q Pat)
tcMetaTy patQTyConName
tcUntypedBracket (DecBrL _) = panic "tcUntypedBracket: Unexpected DecBrL"
tcUntypedBracket (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr"
tc_bracket :: HsBracket Name -> TcRef [PendingSplice] -> TcM (HsExpr TcId)
tc_bracket brack ps_ref
| not (isTypedBracket brack)
= do { mapM_ tcPendingSplice ps
; meta_ty <- tcUntypedBracket brack
; ps' <- readMutVar ps_ref
; co <- unifyType meta_ty res_ty
; return (mkHsWrapCo co (HsBracketOut brack ps'))
}
tc_bracket (TExpBr expr) ps_ref
= do { any_ty <- newFlexiTyVarTy openTypeKind
-- NC for no context; tcBracket does that
; _ <- tcMonoExprNC expr any_ty
; meta_ty <- tcTExpTy any_ty
; ps' <- readMutVar ps_ref
; co <- unifyType meta_ty res_ty
; d <- tcLookupDataCon tExpDataConName
; return (mkHsWrapCo co (unLoc (mkHsConApp d [any_ty] [HsBracketOut brack ps'])))
}
tc_bracket _ _
= panic "tc_bracket: Expected untyped splice"
tcPendingSplice :: PendingSplice -> TcM ()
tcPendingSplice (PendingRnExpSplice n expr)
= do { res_ty <- newFlexiTyVarTy openTypeKind
; _ <- tcSpliceExpr (HsSplice False n expr) res_ty
; return ()
}
tcPendingSplice (PendingRnPatSplice n expr)
= do { res_ty <- newFlexiTyVarTy openTypeKind
; _ <- tcSplicePat (HsSplice False n expr) res_ty
; return ()
}
tcPendingSplice (PendingRnCrossStageSplice n)
= do { res_ty <- newFlexiTyVarTy openTypeKind
; _ <- tcCheckId n res_ty
; return ()
}
tcPendingSplice (PendingRnTypeSplice n expr)
= do { _ <- tcSpliceType (HsSplice False n expr) emptyFVs
; return ()
}
tcPendingSplice (PendingRnDeclSplice n expr)
= do { _ <- tcSpliceDecls (HsSplice False n expr)
; return ()
}
tcPendingSplice (PendingTcSplice _ expr)
= pprPanic "tcPendingSplice: PendingTcSplice" (ppr expr)
tcTExpTy :: TcType -> TcM TcType
tcTExpTy tau = do
t <- tcLookupTyCon tExpTyConName
return (mkTyConApp t [tau])
\end{code}
%************************************************************************
%* *
\subsection{Splicing an expression}
%* *
%************************************************************************
\begin{code}
tcSpliceExpr splice@(HsSplice isTypedSplice name expr) res_ty
= addErrCtxt (spliceCtxtDoc splice) $
setSrcSpan (getLoc expr) $ do
{ stage <- getStage
; case stage of
{ Splice {} | not isTypedSplice -> pprPanic "tcSpliceExpr: encountered unexpanded top-level untyped splice" (ppr splice)
; Comp {} | not isTypedSplice -> pprPanic "tcSpliceExpr: encountered unexpanded top-level untyped splice" (ppr splice)
; Splice {} -> tcTopSplice expr res_ty
; Comp -> tcTopSplice expr res_ty
; Brack isTypedBrack pop_stage ps_var lie_var -> do
{ when (isTypedBrack && not isTypedSplice) $
failWithTc illegalUntypedSplice
; when (not isTypedBrack && isTypedSplice) $
failWithTc illegalTypedSplice
; tc_splice_expr isTypedSplice pop_stage ps_var lie_var
-- The returned expression is ignored
; return (panic "tcSpliceExpr")
}}}
where
tc_splice_expr :: Bool
-> ThStage -> TcRef [PendingSplice] -> TcRef WantedConstraints
-> TcM ()
-- See Note [How brackets and nested splices are handled]
-- A splice inside brackets
-- NB: ignore res_ty, apart from zapping it to a mono-type
-- e.g. [| reverse $(h 4) |]
-- Here (h 4) :: Q Exp
-- but $(h 4) :: forall a.a i.e. anything!
tc_splice_expr False pop_stage ps_var lie_var
= do { meta_exp_ty <- tcMetaTy expQTyConName
; expr' <- setStage pop_stage $
setConstraintVar lie_var $
tcMonoExpr expr meta_exp_ty
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingTcSplice name expr' : ps)
; return ()
}
tc_splice_expr True pop_stage ps_var lie_var
= do { meta_exp_ty <- tcTExpTy res_ty
; expr' <- setStage pop_stage $
setConstraintVar lie_var $
tcMonoExpr expr meta_exp_ty
; unt <- tcLookupId unTypeName
; let expr'' = mkHsApp (nlHsTyApp unt [res_ty]) expr'
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingTcSplice name expr'' : ps)
; return ()
}
tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id)
tcTopSplice expr res_ty
= do { any_ty <- newFlexiTyVarTy openTypeKind
; meta_exp_ty <- tcTExpTy any_ty
-- Typecheck the expression
; zonked_q_expr <- tcTopSpliceExpr True $
tcMonoExpr expr meta_exp_ty
-- Run the expression
; expr2 <- runMetaE zonked_q_expr
; showSplice "expression" expr (ppr expr2)
; addErrCtxt (spliceResultDoc expr) $ do
{ (exp3, _fvs) <- checkNoErrs $ rnLExpr expr2
-- checkNoErrs: see Note [Renamer errors]
; exp4 <- tcMonoExpr exp3 res_ty
; return (unLoc exp4) } }
\end{code}
%************************************************************************
%* *
\subsection{Splicing a pattern}
%* *
%************************************************************************
\begin{code}
tcSplicePat splice@(HsSplice True _ _) _
= pprPanic "tcSplicePat: encountered typed pattern splice" (ppr splice)
tcSplicePat splice@(HsSplice False name expr) _
= addErrCtxt (spliceCtxtDoc splice) $
setSrcSpan (getLoc expr) $ do
{ stage <- getStage
; case stage of
{ Splice {} -> pprPanic "tcSplicePat: encountered unexpanded top-level untyped splice" (ppr splice)
; Comp -> pprPanic "tcSplicePat: encountered unexpanded top-level untyped splice" (ppr splice)
; Brack isTypedBrack pop_stage ps_var lie_var -> do
{ checkTc (not isTypedBrack) illegalUntypedSplice
; meta_exp_ty <- tcMetaTy patQTyConName
; expr' <- setStage pop_stage $
setConstraintVar lie_var $
tcMonoExpr expr meta_exp_ty
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingTcSplice name expr' : ps)
-- The returned expression is ignored
; return (panic "tcSplicePat")
}}}
\end{code}
%************************************************************************
%* *
\subsection{Error messages}
%* *
%************************************************************************
\begin{code}
quotationCtxtDoc :: HsBracket Name -> SDoc
quotationCtxtDoc br_body
= hang (ptext (sLit "In the Template Haskell quotation"))
2 (ppr br_body)
spliceCtxtDoc :: HsSplice Name -> SDoc
spliceCtxtDoc splice
= hang (ptext (sLit "In the Template Haskell splice"))
2 (ppr splice)
spliceResultDoc :: LHsExpr Name -> SDoc
spliceResultDoc expr
= sep [ ptext (sLit "In the result of the splice:")
, nest 2 (char '$' <> pprParendExpr expr)
, ptext (sLit "To see what the splice expanded to, use -ddump-splices")]
-------------------
tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id)
-- Note [How top-level splices are handled]
-- Type check an expression that is the body of a top-level splice
-- (the caller will compile and run it)
-- Note that set the level to Splice, regardless of the original level,
-- before typechecking the expression. For example:
-- f x = $( ...$(g 3) ... )
-- The recursive call to tcMonoExpr will simply expand the
-- inner escape before dealing with the outer one
tcTopSpliceExpr isTypedSplice tc_action
= checkNoErrs $ -- checkNoErrs: must not try to run the thing
-- if the type checker fails!
unsetDOptM Opt_DeferTypeErrors $
-- Don't defer type errors. Not only are we
-- going to run this code, but we do an unsafe
-- coerce, so we get a seg-fault if, say we
-- splice a type into a place where an expression
-- is expected (Trac #7276)
setStage (Splice isTypedSplice) $
do { -- Typecheck the expression
(expr', lie) <- captureConstraints tc_action
-- Solve the constraints
; const_binds <- simplifyTop lie
-- Zonk it and tie the knot of dictionary bindings
; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') }
\end{code}
Note [Renamer errors]
~~~~~~~~~~~~~~~~~~~~~
It's important to wrap renamer calls in checkNoErrs, because the
renamer does not fail for out of scope variables etc. Instead it
returns a bogus term/type, so that it can report more than one error.
We don't want the type checker to see these bogus unbound variables.
%************************************************************************
%* *
Splicing a type
%* *
%************************************************************************
Very like splicing an expression, but we don't yet share code.
\begin{code}
tcSpliceType splice@(HsSplice True _ _) _
= pprPanic "tcSpliceType: encountered a typed type splice" (ppr splice)
tcSpliceType splice@(HsSplice False name expr) _
= setSrcSpan (getLoc expr) $ do
{ stage <- getStage
; case stage of
{ Brack isTypedBrack pop_stage ps_var lie_var -> do
-- See Note [How brackets and nested splices are handled]
-- A splice inside brackets
{ meta_ty <- tcMetaTy typeQTyConName
; when isTypedBrack $
failWithTc illegalUntypedSplice
; expr' <- setStage pop_stage $
setConstraintVar lie_var $
tcMonoExpr expr meta_ty
-- Write the pending splice into the bucket
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingTcSplice name expr' : ps)
-- e.g. [| f (g :: Int -> $(h 4)) |]
-- Here (h 4) :: Q Type
-- but $(h 4) :: a i.e. any type, of any kind
; kind <- newMetaKindVar
; ty <- newFlexiTyVarTy kind
; return (ty, kind)
}
; _ -> pprPanic "tcSpliceType: encountered unexpanded top-level type splice" (ppr splice)
}}
\end{code}
%************************************************************************
%* *
\subsection{Splicing an expression}
%* *
%************************************************************************
\begin{code}
-- Note [How top-level splices are handled]
-- Always at top level
-- Type sig at top of file:
-- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcSpliceDecls splice@(HsSplice True _ _)
= pprPanic "tcSpliceDecls: encountered a typed type splice" (ppr splice)
tcSpliceDecls (HsSplice False _ expr)
= do { list_q <- tcMetaTy decsQTyConName -- Q [Dec]
; zonked_q_expr <- tcTopSpliceExpr False (tcMonoExpr expr list_q)
-- Run the expression
; decls <- runMetaD zonked_q_expr
; showSplice "declarations" expr
(ppr (getLoc expr) $$ (vcat (map ppr decls)))
; return decls }
\end{code}
%************************************************************************
%* *
Annotations
%* *
%************************************************************************
\begin{code}
runAnnotation target expr = do
-- Find the classes we want instances for in order to call toAnnotationWrapper
loc <- getSrcSpanM
data_class <- tcLookupClass dataClassName
to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
-- Check the instances we require live in another module (we want to execute it..)
-- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
-- also resolves the LIE constraints to detect e.g. instance ambiguity
zonked_wrapped_expr' <- tcTopSpliceExpr False $
do { (expr', expr_ty) <- tcInferRhoNC expr
-- We manually wrap the typechecked expression in a call to toAnnotationWrapper
-- By instantiating the call >here< it gets registered in the
-- LIE consulted by tcTopSpliceExpr
-- and hence ensures the appropriate dictionary is bound by const_binds
; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
; let specialised_to_annotation_wrapper_expr
= L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
-- Run the appropriately wrapped expression to get the value of
-- the annotation and its dictionaries. The return value is of
-- type AnnotationWrapper by construction, so this conversion is
-- safe
flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper ->
case annotation_wrapper of
AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
-- Got the value and dictionaries: build the serialized value and
-- call it a day. We ensure that we seq the entire serialized value
-- in order that any errors in the user-written code for the
-- annotation are exposed at this point. This is also why we are
-- doing all this stuff inside the context of runMeta: it has the
-- facilities to deal with user error in a meta-level expression
seqSerialized serialized `seq` Annotation {
ann_target = target,
ann_value = serialized
}
\end{code}
%************************************************************************
%* *
Quasi-quoting
%* *
%************************************************************************
Note [Quasi-quote overview]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
The GHC "quasi-quote" extension is described by Geoff Mainland's paper
"Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
Workshop 2007).
Briefly, one writes
[p| stuff |]
and the arbitrary string "stuff" gets parsed by the parser 'p', whose
type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be
defined in another module, because we are going to run it here. It's
a bit like a TH splice:
$(p "stuff")
However, you can do this in patterns as well as terms. Becuase of this,
the splice is run by the *renamer* rather than the type checker.
%************************************************************************
%* *
\subsubsection{Quasiquotation}
%* *
%************************************************************************
See Note [Quasi-quote overview] in TcSplice.
\begin{code}
runQuasiQuote :: Outputable hs_syn
=> HsQuasiQuote RdrName -- Contains term of type QuasiQuoter, and the String
-> Name -- Of type QuasiQuoter -> String -> Q th_syn
-> Name -- Name of th_syn type
-> MetaOps th_syn hs_syn
-> RnM hs_syn
runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops
= do { -- Drop the leading "$" from the quoter name, if present
-- This is old-style syntax, now deprecated
-- NB: when removing this backward-compat, remove
-- the matching code in Lexer.x (around line 310)
let occ_str = occNameString (rdrNameOcc quoter)
; quoter <- ASSERT( not (null occ_str) ) -- Lexer ensures this
if head occ_str /= '$' then return quoter
else do { addWarn (deprecatedDollar quoter)
; return (mkRdrUnqual (mkVarOcc (tail occ_str))) }
; quoter' <- lookupOccRn quoter
-- We use lookupOcc rather than lookupGlobalOcc because in the
-- erroneous case of \x -> [x| ...|] we get a better error message
-- (stage restriction rather than out of scope).
; when (isUnboundName quoter') failM
-- If 'quoter' is not in scope, proceed no further
-- The error message was generated by lookupOccRn, but it then
-- succeeds with an "unbound name", which makes the subsequent
-- attempt to run the quote fail in a confusing way
-- Check that the quoter is not locally defined, otherwise the TH
-- machinery will not be able to run the quasiquote.
; this_mod <- getModule
; let is_local = nameIsLocalOrFrom this_mod quoter'
; checkTc (not is_local) (quoteStageError quoter')
; traceTc "runQQ" (ppr quoter <+> ppr is_local)
-- Build the expression
; let quoterExpr = L q_span $! HsVar $! quoter'
; let quoteExpr = L q_span $! HsLit $! HsString quote
; let expr = L q_span $
HsApp (L q_span $
HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
; meta_exp_ty <- tcMetaTy meta_ty
-- Typecheck the expression
; zonked_q_expr <- tcTopSpliceExpr False (tcMonoExpr expr meta_exp_ty)
-- Run the expression
; result <- runMetaQ meta_ops zonked_q_expr
; showSplice (mt_desc meta_ops) quoteExpr (ppr result)
; return result }
runQuasiQuoteExpr qq = runQuasiQuote qq quoteExpName expQTyConName exprMetaOps
runQuasiQuotePat qq = runQuasiQuote qq quotePatName patQTyConName patMetaOps
runQuasiQuoteType qq = runQuasiQuote qq quoteTypeName typeQTyConName typeMetaOps
runQuasiQuoteDecl qq = runQuasiQuote qq quoteDecName decsQTyConName declMetaOps
quoteStageError :: Name -> SDoc
quoteStageError quoter
= sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
deprecatedDollar :: RdrName -> SDoc
deprecatedDollar quoter
= hang (ptext (sLit "Deprecated syntax:"))
2 (ptext (sLit "quasiquotes no longer need a dollar sign:")
<+> ppr quoter)
\end{code}
%************************************************************************
%* *
\subsection{Running an expression}
%* *
%************************************************************************
\begin{code}
data MetaOps th_syn hs_syn
= MT { mt_desc :: String -- Type of beast (expression, type etc)
, mt_show :: th_syn -> String -- How to show the th_syn thing
, mt_cvt :: SrcSpan -> th_syn -> Either MsgDoc hs_syn
-- How to convert to hs_syn
}
exprMetaOps :: MetaOps TH.Exp (LHsExpr RdrName)
exprMetaOps = MT { mt_desc = "expression", mt_show = TH.pprint, mt_cvt = convertToHsExpr }
patMetaOps :: MetaOps TH.Pat (LPat RdrName)
patMetaOps = MT { mt_desc = "pattern", mt_show = TH.pprint, mt_cvt = convertToPat }
typeMetaOps :: MetaOps TH.Type (LHsType RdrName)
typeMetaOps = MT { mt_desc = "type", mt_show = TH.pprint, mt_cvt = convertToHsType }
declMetaOps :: MetaOps [TH.Dec] [LHsDecl RdrName]
declMetaOps = MT { mt_desc = "declarations", mt_show = TH.pprint, mt_cvt = convertToHsDecls }
----------------
runMetaAW :: Outputable output
=> (AnnotationWrapper -> output)
-> LHsExpr Id -- Of type AnnotationWrapper
-> TcM output
runMetaAW k = runMeta False (\_ -> return . Right . k)
-- We turn off showing the code in meta-level exceptions because doing so exposes
-- the toAnnotationWrapper function that we slap around the users code
-----------------
runMetaQ :: Outputable hs_syn
=> MetaOps th_syn hs_syn
-> LHsExpr Id
-> TcM hs_syn
runMetaQ (MT { mt_show = show_th, mt_cvt = cvt }) expr
= runMeta True run_and_cvt expr
where
run_and_cvt expr_span hval
= do { th_result <- TH.runQ hval
; traceTc "Got TH result:" (text (show_th th_result))
; return (cvt expr_span th_result) }
runMetaE :: LHsExpr Id -- Of type (Q Exp)
-> TcM (LHsExpr RdrName)
runMetaE = runMetaQ exprMetaOps
runMetaP :: LHsExpr Id -- Of type (Q Pat)
-> TcM (LPat RdrName)
runMetaP = runMetaQ patMetaOps
runMetaT :: LHsExpr Id -- Of type (Q Type)
-> TcM (LHsType RdrName)
runMetaT = runMetaQ typeMetaOps
runMetaD :: LHsExpr Id -- Of type Q [Dec]
-> TcM [LHsDecl RdrName]
runMetaD = runMetaQ declMetaOps
---------------
runMeta :: (Outputable hs_syn)
=> Bool -- Whether code should be printed in the exception message
-> (SrcSpan -> x -> TcM (Either MsgDoc hs_syn)) -- How to run x
-> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that
-> TcM hs_syn -- Of type t
runMeta show_code run_and_convert expr
= do { traceTc "About to run" (ppr expr)
; recordThSpliceUse -- seems to be the best place to do this,
-- we catch all kinds of splices and annotations.
-- Check that we've had no errors of any sort so far.
-- For example, if we found an error in an earlier defn f, but
-- recovered giving it type f :: forall a.a, it'd be very dodgy
-- to carry ont. Mind you, the staging restrictions mean we won't
-- actually run f, but it still seems wrong. And, more concretely,
-- see Trac #5358 for an example that fell over when trying to
-- reify a function with a "?" kind in it. (These don't occur
-- in type-correct programs.
; failIfErrsM
-- Desugar
; ds_expr <- initDsTc (dsLExpr expr)
-- Compile and link it; might fail if linking fails
; hsc_env <- getTopEnv
; src_span <- getSrcSpanM
; traceTc "About to run (desugared)" (ppr ds_expr)
; either_hval <- tryM $ liftIO $
HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
; case either_hval of {
Left exn -> fail_with_exn "compile and link" exn ;
Right hval -> do
{ -- Coerce it to Q t, and run it
-- Running might fail if it throws an exception of any kind (hence tryAllM)
-- including, say, a pattern-match exception in the code we are running
--
-- We also do the TH -> HS syntax conversion inside the same
-- exception-cacthing thing so that if there are any lurking
-- exceptions in the data structure returned by hval, we'll
-- encounter them inside the try
--
-- See Note [Exceptions in TH]
let expr_span = getLoc expr
; either_tval <- tryAllM $
setSrcSpan expr_span $ -- Set the span so that qLocation can
-- see where this splice is
do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
; case mb_result of
Left err -> failWithTc err
Right result -> do { traceTc "Got HsSyn result:" (ppr result)
; return $! result } }
; case either_tval of
Right v -> return v
Left se -> case fromException se of
Just IOEnvFailure -> failM -- Error already in Tc monad
_ -> fail_with_exn "run" se -- Exception
}}}
where
-- see Note [Concealed TH exceptions]
fail_with_exn phase exn = do
exn_msg <- liftIO $ Panic.safeShowException exn
let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
nest 2 (text exn_msg),
if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
failWithTc msg
\end{code}
Note [Exceptions in TH]
~~~~~~~~~~~~~~~~~~~~~~~
Supppose we have something like this
$( f 4 )
where
f :: Int -> Q [Dec]
f n | n>3 = fail "Too many declarations"
| otherwise = ...
The 'fail' is a user-generated failure, and should be displayed as a
perfectly ordinary compiler error message, not a panic or anything
like that. Here's how it's processed:
* 'fail' is the monad fail. The monad instance for Q in TH.Syntax
effectively transforms (fail s) to
qReport True s >> fail
where 'qReport' comes from the Quasi class and fail from its monad
superclass.
* The TcM monad is an instance of Quasi (see TcSplice), and it implements
(qReport True s) by using addErr to add an error message to the bag of errors.
The 'fail' in TcM raises an IOEnvFailure exception
* So, when running a splice, we catch all exceptions; then for
- an IOEnvFailure exception, we assume the error is already
in the error-bag (above)
- other errors, we add an error to the bag
and then fail
Note [Concealed TH exceptions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When displaying the error message contained in an exception originated from TH
code, we need to make sure that the error message itself does not contain an
exception. For example, when executing the following splice:
$( error ("foo " ++ error "bar") )
the message for the outer exception is a thunk which will throw the inner
exception when evaluated.