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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Rename.Splice (
rnTopSpliceDecls,
-- Typed splices
rnTypedSplice,
-- Untyped splices
rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceDecl,
-- Brackets
rnTypedBracket, rnUntypedBracket,
checkThLocalName, traceSplice, SpliceInfo(..)
) where
import GHC.Prelude
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Driver.Env.Types
import GHC.Rename.Env
import GHC.Rename.Utils ( newLocalBndrRn )
import GHC.Rename.Unbound ( isUnboundName )
import GHC.Rename.Module ( rnSrcDecls, findSplice )
import GHC.Rename.Pat ( rnPat )
import GHC.Types.Error
import GHC.Types.Basic ( TopLevelFlag, isTopLevel, maxPrec )
import GHC.Types.SourceText ( SourceText(..) )
import GHC.Utils.Outputable
import GHC.Unit.Module
import GHC.Types.SrcLoc
import GHC.Rename.HsType ( rnLHsType )
import Control.Monad ( unless, when )
import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
import GHC.Tc.Utils.Env ( checkWellStaged, tcMetaTy )
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Driver.Hooks
import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName
, patQTyConName, quoteDecName, quoteExpName
, quotePatName, quoteTypeName, typeQTyConName)
import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckPolyExpr )
import {-# SOURCE #-} GHC.Tc.Gen.Splice
( runMetaD
, runMetaE
, runMetaP
, runMetaT
, tcTopSpliceExpr
)
import GHC.Tc.Utils.Zonk
import GHCi.RemoteTypes ( ForeignRef )
import qualified Language.Haskell.TH as TH (Q)
import qualified GHC.LanguageExtensions as LangExt
{-
************************************************************************
* *
Template Haskell brackets
* *
************************************************************************
-}
-- Check that -XTemplateHaskellQuotes is enabled and available
checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM ()
checkForTemplateHaskellQuotes e =
do { thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes
; unless thQuotesEnabled $
failWith ( mkTcRnUnknownMessage $ mkPlainError noHints $ vcat
[ text "Syntax error on" <+> ppr e
, text ("Perhaps you intended to use TemplateHaskell"
++ " or TemplateHaskellQuotes") ] )
}
rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnTypedBracket e br_body
= addErrCtxt (typedQuotationCtxtDoc br_body) $
do { checkForTemplateHaskellQuotes e
-- Check for nested brackets
; cur_stage <- getStage
; case cur_stage of
{ Splice Typed -> return ()
; Splice Untyped -> failWithTc illegalTypedBracket
; RunSplice _ ->
-- See Note [RunSplice ThLevel] in GHC.Tc.Types.
pprPanic "rnTypedBracket: Renaming typed bracket when running a splice"
(ppr e)
; Comp -> return ()
; Brack {} -> failWithTc illegalBracket
}
-- Brackets are desugared to code that mentions the TH package
; recordThUse
; traceRn "Renaming typed TH bracket" empty
; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body
; return (HsTypedBracket noExtField body', fvs_e)
}
rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnUntypedBracket e br_body
= addErrCtxt (untypedQuotationCtxtDoc br_body) $
do { checkForTemplateHaskellQuotes e
-- Check for nested brackets
; cur_stage <- getStage
; case cur_stage of
{ Splice Typed -> failWithTc illegalUntypedBracket
; Splice Untyped -> return ()
; RunSplice _ ->
-- See Note [RunSplice ThLevel] in GHC.Tc.Types.
pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice"
(ppr e)
; Comp -> return ()
; Brack {} -> failWithTc illegalBracket
}
-- Brackets are desugared to code that mentions the TH package
; recordThUse
; traceRn "Renaming untyped TH bracket" empty
; ps_var <- newMutVar []
; (body', fvs_e) <-
-- See Note [Rebindable syntax and Template Haskell]
unsetXOptM LangExt.RebindableSyntax $
setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
rn_utbracket cur_stage br_body
; pendings <- readMutVar ps_var
; return (HsUntypedBracket pendings body', fvs_e)
}
rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)
rn_utbracket outer_stage br@(VarBr x flg rdr_name)
= do { name <- lookupOccRn (unLoc rdr_name)
; check_namespace flg name
; this_mod <- getModule
; when (flg && nameIsLocalOrFrom this_mod name) $
-- Type variables can be quoted in TH. See #5721.
do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
; case mb_bind_lvl of
{ Nothing -> return () -- Can happen for data constructors,
-- but nothing needs to be done for them
; Just (top_lvl, bind_lvl) -- See Note [Quoting names]
| isTopLevel top_lvl
-> when (isExternalName name) (keepAlive name)
| otherwise
-> do { traceRn "rn_utbracket VarBr"
(ppr name <+> ppr bind_lvl
<+> ppr outer_stage)
; checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr br) }
}
}
; return (VarBr x flg (noLocA name), unitFV name) }
rn_utbracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr x e', fvs) }
rn_utbracket _ (PatBr x p)
= rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)
rn_utbracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t
; return (TypBr x t', fvs) }
rn_utbracket _ (DecBrL x decls)
= do { group <- groupDecls decls
; gbl_env <- getGblEnv
; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
-- The emptyDUs is so that we just collect uses for this
-- group alone in the call to rnSrcDecls below
; (tcg_env, group') <- setGblEnv new_gbl_env $
rnSrcDecls group
-- Discard the tcg_env; it contains only extra info about fixity
; traceRn "rn_utbracket dec" (ppr (tcg_dus tcg_env) $$
ppr (duUses (tcg_dus tcg_env)))
; return (DecBrG x group', duUses (tcg_dus tcg_env)) }
where
groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls decls
= do { (group, mb_splice) <- findSplice decls
; case mb_splice of
{ Nothing -> return group
; Just (splice, rest) ->
do { group' <- groupDecls rest
; let group'' = appendGroups group group'
; return group'' { hs_splcds = noLocA splice : hs_splcds group' }
}
}}
rn_utbracket _ (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG"
-- | Ensure that we are not using a term-level name in a type-level namespace
-- or vice-versa. Throws a 'TcRnIncorrectNameSpace' error if there is a problem.
check_namespace :: Bool -> Name -> RnM ()
check_namespace is_single_tick nm
= unless (isValNameSpace ns == is_single_tick) $
failWithTc $ (TcRnIncorrectNameSpace nm True)
where
ns = nameNameSpace nm
typedQuotationCtxtDoc :: LHsExpr GhcPs -> SDoc
typedQuotationCtxtDoc br_body
= hang (text "In the Template Haskell typed quotation")
2 (thTyBrackets . ppr $ br_body)
untypedQuotationCtxtDoc :: HsQuote GhcPs -> SDoc
untypedQuotationCtxtDoc br_body
= hang (text "In the Template Haskell quotation")
2 (ppr br_body)
illegalBracket :: TcRnMessage
illegalBracket = mkTcRnUnknownMessage $ mkPlainError noHints $
text "Template Haskell brackets cannot be nested" <+>
text "(without intervening splices)"
illegalTypedBracket :: TcRnMessage
illegalTypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $
text "Typed brackets may only appear in typed splices."
illegalUntypedBracket :: TcRnMessage
illegalUntypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $
text "Untyped brackets may only appear in untyped splices."
quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage
quotedNameStageErr br
= mkTcRnUnknownMessage $ mkPlainError noHints $
sep [ text "Stage error: the non-top-level quoted name" <+> ppr br
, text "must be used at the same stage at which it is bound" ]
{-
*********************************************************
* *
Splices
* *
*********************************************************
Note [Free variables of typed splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider renaming this:
f = ...
h = ...$(thing "f")...
where the splice is a *typed* splice. The splice can expand into
literally anything, so when we do dependency analysis we must assume
that it might mention 'f'. So we simply treat all locally-defined
names as mentioned by any splice. This is terribly brutal, but I
don't see what else to do. For example, it'll mean that every
locally-defined thing will appear to be used, so no unused-binding
warnings. But if we miss the dependency, then we might typecheck 'h'
before 'f', and that will crash the type checker because 'f' isn't in
scope.
Currently, I'm not treating a splice as also mentioning every import,
which is a bit inconsistent -- but there are a lot of them. We might
thereby get some bogus unused-import warnings, but we won't crash the
type checker. Not very satisfactory really.
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.
-}
rnUntypedSpliceGen :: (HsUntypedSplice GhcRn -> RnM (a, FreeVars))
-- Outside brackets, run splice
-> (Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, a))
-- Inside brackets, make it pending
-> HsUntypedSplice GhcPs
-> RnM (a, FreeVars)
rnUntypedSpliceGen run_splice pend_splice splice
= addErrCtxt (spliceCtxt splice) $ do
{ stage <- getStage
; case stage of
Brack _ RnPendingTyped
-> failWithTc illegalUntypedSplice
Brack pop_stage (RnPendingUntyped ps_var)
-> do { (splice', fvs) <- setStage pop_stage $
rnUntypedSplice splice
; loc <- getSrcSpanM
; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
; let (pending_splice, result) = pend_splice splice_name splice'
; ps <- readMutVar ps_var
; writeMutVar ps_var (pending_splice : ps)
; return (result, fvs) }
_ -> do { checkTopSpliceAllowed splice
; (splice', fvs1) <- checkNoErrs $
setStage (Splice Untyped) $
rnUntypedSplice splice
-- checkNoErrs: don't attempt to run the splice if
-- renaming it failed; otherwise we get a cascade of
-- errors from e.g. unbound variables
; (result, fvs2) <- run_splice splice'
; return (result, fvs1 `plusFV` fvs2) } }
-- Nested splices are fine without TemplateHaskell because they
-- are not executed until the top-level splice is run.
checkTopSpliceAllowed :: HsUntypedSplice GhcPs -> RnM ()
checkTopSpliceAllowed splice = do
let (herald, ext) = spliceExtension splice
extEnabled <- xoptM ext
unless extEnabled
(failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $
text herald <+> text "are not permitted without" <+> ppr ext)
where
spliceExtension :: HsUntypedSplice GhcPs -> (String, LangExt.Extension)
spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes)
spliceExtension (HsUntypedSpliceExpr {}) = ("Top-level splices", LangExt.TemplateHaskell)
------------------
-- | Returns the result of running a splice and the modFinalizers collected
-- during the execution.
--
-- See Note [Delaying modFinalizers in untyped splices].
runRnSplice :: UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc) -- How to pretty-print res
-- Usually just ppr, but not for [Decl]
-> HsUntypedSplice GhcRn
-> TcRn (res, [ForeignRef (TH.Q ())])
runRnSplice flavour run_meta ppr_res splice
= do { hooks <- hsc_hooks <$> getTopEnv
; splice' <- case runRnSpliceHook hooks of
Nothing -> return splice
Just h -> h splice
; let the_expr = case splice' of
HsUntypedSpliceExpr _ e -> e
HsQuasiQuote _ q str -> mkQuasiQuoteExpr flavour q str
-- Typecheck the expression
; meta_exp_ty <- tcMetaTy meta_ty_name
; zonked_q_expr <- zonkTopLExpr =<<
tcTopSpliceExpr Untyped
(tcCheckPolyExpr the_expr meta_exp_ty)
-- Run the expression
; mod_finalizers_ref <- newTcRef []
; result <- setStage (RunSplice mod_finalizers_ref) $
run_meta zonked_q_expr
; mod_finalizers <- readTcRef mod_finalizers_ref
; traceSplice (SpliceInfo { spliceDescription = what
, spliceIsDecl = is_decl
, spliceSource = Just the_expr
, spliceGenerated = ppr_res result })
; return (result, mod_finalizers) }
where
meta_ty_name = case flavour of
UntypedExpSplice -> expQTyConName
UntypedPatSplice -> patQTyConName
UntypedTypeSplice -> typeQTyConName
UntypedDeclSplice -> decsQTyConName
what = case flavour of
UntypedExpSplice -> "expression"
UntypedPatSplice -> "pattern"
UntypedTypeSplice -> "type"
UntypedDeclSplice -> "declarations"
is_decl = case flavour of
UntypedDeclSplice -> True
_ -> False
------------------
makePending :: UntypedSpliceFlavour
-> Name
-> HsUntypedSplice GhcRn
-> PendingRnSplice
makePending flavour n (HsUntypedSpliceExpr _ e)
= PendingRnSplice flavour n e
makePending flavour n (HsQuasiQuote _ quoter quote)
= PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter quote)
------------------
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name
-> XRec GhcPs FastString
-> LHsExpr GhcRn
-- Return the expression (quoter "...quote...")
-- which is what we must run in a quasi-quote
mkQuasiQuoteExpr flavour quoter (L q_span' quote)
= L q_span $ HsApp noComments (L q_span
$ HsApp noComments (L q_span
(HsVar noExtField (L (la2na q_span) quote_selector)))
quoterExpr)
quoteExpr
where
q_span = noAnnSrcSpan (locA q_span')
quoterExpr = L q_span $! HsVar noExtField $! (L (la2na q_span) quoter)
quoteExpr = L q_span $! HsLit noComments $! HsString NoSourceText quote
quote_selector = case flavour of
UntypedExpSplice -> quoteExpName
UntypedPatSplice -> quotePatName
UntypedTypeSplice -> quoteTypeName
UntypedDeclSplice -> quoteDecName
---------------------
unqualSplice :: RdrName
-- The RdrName for a SplicePointName. See GHC.Hs.Expr
-- Note [Lifecycle of an untyped splice, and PendingRnSplice]
-- We use "spn" (which is arbitrary) because it is brief but grepable-for.
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "spn"))
rnUntypedSplice :: HsUntypedSplice GhcPs -> RnM (HsUntypedSplice GhcRn, FreeVars)
-- Not exported...used for all
rnUntypedSplice (HsUntypedSpliceExpr annCo expr)
= do { (expr', fvs) <- rnLExpr expr
; return (HsUntypedSpliceExpr annCo expr', fvs) }
rnUntypedSplice (HsQuasiQuote ext quoter quote)
= do { -- Rename the quoter; akin to the HsVar case of rnExpr
; quoter' <- lookupOccRn quoter
; this_mod <- getModule
; when (nameIsLocalOrFrom this_mod quoter') $
checkThLocalName quoter'
; return (HsQuasiQuote ext quoter' quote, unitFV quoter') }
---------------------
rnTypedSplice :: LHsExpr GhcPs -- Typed splice expression
-> RnM (HsExpr GhcRn, FreeVars)
rnTypedSplice expr
= addErrCtxt (hang (text "In the typed splice:") 2 (pprTypedSplice Nothing expr)) $ do
{ stage <- getStage
; case stage of
Brack pop_stage RnPendingTyped
-> setStage pop_stage rn_splice
Brack _ (RnPendingUntyped _)
-> failWithTc illegalTypedSplice
_ -> do { extEnabled <- xoptM LangExt.TemplateHaskell
; unless extEnabled
(failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $
text "Top-level splices are not permitted without"
<+> ppr LangExt.TemplateHaskell)
; (result, fvs1) <- checkNoErrs $ setStage (Splice Typed) rn_splice
-- checkNoErrs: don't attempt to run the splice if
-- renaming it failed; otherwise we get a cascade of
-- errors from e.g. unbound variables
-- Run typed splice later, in the type checker
-- Ugh! See Note [Free variables of typed splices] above
; traceRn "rnTypedSplice: typed expression splice" empty
; lcl_rdr <- getLocalRdrEnv
; gbl_rdr <- getGlobalRdrEnv
; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr
, isLocalGRE gre]
lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
fvs2 = lcl_names `plusFV` gbl_names
; return (result, fvs1 `plusFV` fvs2) } }
where
rn_splice :: RnM (HsExpr GhcRn, FreeVars)
rn_splice =
do { loc <- getSrcSpanM
-- The renamer allocates a splice-point name to every typed splice
-- (incl the top level ones for which it will not ultimately be used)
; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
; (expr', fvs) <- rnLExpr expr
; return (HsTypedSplice n' expr', fvs) }
rnUntypedSpliceExpr :: HsUntypedSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnUntypedSpliceExpr splice
= rnUntypedSpliceGen run_expr_splice pend_expr_splice splice
where
pend_expr_splice :: Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
pend_expr_splice name rn_splice
= (makePending UntypedExpSplice name rn_splice, HsUntypedSplice (HsUntypedSpliceNested name) rn_splice)
run_expr_splice :: HsUntypedSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
run_expr_splice rn_splice
= do { traceRn "rnUntypedSpliceExpr: untyped expression splice" empty
-- Run it here, see Note [Running splices in the Renamer]
; (rn_expr, mod_finalizers) <-
runRnSplice UntypedExpSplice runMetaE ppr rn_splice
; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
-- See Note [Delaying modFinalizers in untyped splices].
; let e = flip HsUntypedSplice rn_splice
. HsUntypedSpliceTop (ThModFinalizers mod_finalizers)
<$> lexpr3
; return (gHsPar e, fvs)
}
{- Note [Running splices in the Renamer]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Splices used to be run in the typechecker, which led to (#4364). Since the
renamer must decide which expressions depend on which others, and it cannot
reliably do this for arbitrary splices, we used to conservatively say that
splices depend on all other expressions in scope. Unfortunately, this led to
the problem of cyclic type declarations seen in (#4364). Instead, by
running splices in the renamer, we side-step the problem of determining
dependencies: by the time the dependency analysis happens, any splices have
already been run, and expression dependencies can be determined as usual.
However, see (#9813), for an example where we would like to run splices
*after* performing dependency analysis (that is, after renaming). It would be
desirable to typecheck "non-splicy" expressions (those expressions that do not
contain splices directly or via dependence on an expression that does) before
"splicy" expressions, such that types/expressions within the same declaration
group would be available to `reify` calls, for example consider the following:
> module M where
> data D = C
> f = 1
> g = $(mapM reify ['f, 'D, ''C] ...)
Compilation of this example fails since D/C/f are not in the type environment
and thus cannot be reified as they have not been typechecked by the time the
splice is renamed and thus run.
These requirements are at odds: we do not want to run splices in the renamer as
we wish to first determine dependencies and typecheck certain expressions,
making them available to reify, but cannot accurately determine dependencies
without running splices in the renamer!
Indeed, the conclusion of (#9813) was that it is not worth the complexity
to try and
a) implement and maintain the code for renaming/typechecking non-splicy
expressions before splicy expressions,
b) explain to TH users which expressions are/not available to reify at any
given point.
-}
{- Note [Rebindable syntax and Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When processing Template Haskell quotes with Rebindable Syntax (RS) enabled,
there are two possibilities: apply the RS rules to the quotes or don't.
One might expect that with {-# LANGUAGE RebindableSyntax #-} at the top of a
module, any 'if' expression would end up being turned into a call to whatever
'ifThenElse' function is in scope, regardless of whether the said if expression
appears in "normal" Haskell code or in a TH quote. This however comes with its
problems. Consider the following code:
{-# LANGUAGE TemplateHaskell, RebindableSyntax #-}
module X where
import Prelude ( Monad(..), Bool(..), print, ($) )
import Language.Haskell.TH.Syntax
$( do stuff <- [| if True then 10 else 15 |]
runIO $ print stuff
return [] )
If we apply the RS rules, then GHC would complain about not having suitable
fromInteger/ifThenElse functions in scope. But this quote is just a bit of
Haskell syntax that has yet to be used, or, to put it differently, placed
(spliced) in some context where the said functions might be available. More
generally, untyped TH quotes are meant to work with yet-unbound identifiers.
This tends to show that untyped TH and Rebindable Syntax overall don't play
well together. Users still have the option to splice "normal" if expressions
into modules where RS is enabled, to turn them into applications of
an 'ifThenElse' function of their choice.
Typed TH (TTH) quotes, on the other hand, come with different constraints. They
don't quite have this "delayed" nature: we typecheck them while processing
them, and TTH users expect RS to Just Work in their quotes, exactly like it does
outside of the quotes. There, we do not have to accept unbound identifiers and
we can apply the RS rules both in the typechecking and desugaring of the quotes
without triggering surprising/bad behaviour for users. For instance, the
following code is expected to be rejected (because of the lack of suitable
'fromInteger'/'ifThenElse' functions in scope):
{-# LANGUAGE TemplateHaskell, RebindableSyntax #-}
module X where
import Prelude ( Monad(..), Bool(..), print, ($) )
import Language.Haskell.TH.Syntax
$$( do stuff <- [|| if True then 10 else 15 ||]
runIO $ print stuff
return [] )
The conclusion is that even if RS is enabled for a given module, GHC disables it
when processing untyped TH quotes from that module, to avoid the aforementioned
problems, but keeps it on while processing typed TH quotes.
This note and approach originated in #18102.
-}
{- Note [Delaying modFinalizers in untyped splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When splices run in the renamer, 'reify' does not have access to the local
type environment (#11832, [1]).
For instance, in
> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |])
'reify' cannot find @x@, because the local type environment is not yet
populated. To address this, we allow 'reify' execution to be deferred with
'addModFinalizer'.
> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print)
[| return () |]
)
The finalizer is run with the local type environment when type checking is
complete.
Since the local type environment is not available in the renamer, we annotate
the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where
@e@ is the result of splicing and @finalizers@ are the finalizers that have been
collected during evaluation of the splice [3]. In our example,
> HsLet
> (x = e)
> (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print]
> (HsSplicedExpr $ return ())
> )
When the typechecker finds the annotation, it inserts the finalizers in the
global environment and exposes the current local environment to them [4, 5, 6].
> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print]
References:
[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify
[2] 'rnSpliceExpr'
[3] 'GHC.Tc.Gen.Splice.qAddModFinalizer'
[4] 'GHC.Tc.Gen.Expr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))
[5] 'GHC.Tc.Gen.HsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...))
[6] 'GHC.Tc.Gen.Pat.tc_pat' ('SplicePat' ('HsSpliced' ...))
-}
----------------------
rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
rnSpliceType splice
= rnUntypedSpliceGen run_type_splice pend_type_splice splice
where
pend_type_splice name rn_splice
= ( makePending UntypedTypeSplice name rn_splice
, HsSpliceTy (HsUntypedSpliceNested name) rn_splice)
run_type_splice :: HsUntypedSplice GhcRn -> RnM (HsType GhcRn, FreeVars)
run_type_splice rn_splice
= do { traceRn "rnSpliceType: untyped type splice" empty
; (hs_ty2, mod_finalizers) <-
runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
; checkNoErrs $ rnLHsType doc hs_ty2 }
-- checkNoErrs: see Note [Renamer errors]
-- See Note [Delaying modFinalizers in untyped splices].
; return ( HsSpliceTy (HsUntypedSpliceTop (ThModFinalizers mod_finalizers)
(mb_paren hs_ty3))
rn_splice
, fvs
) }
-- Wrap the result of the splice in parens so that we don't
-- lose the outermost location set by runQuasiQuote (#7918)
-- Wrap a non-atomic result in HsParTy parens;
-- but not if it's atomic to avoid double parens for operators
-- This is to account for, say foo :: $(blah) -> Int
-- when we want $(blah) to expand to (this -> that), with parens.
-- Sadly, it's awkward add precisely the correct parens, because
-- that depends on the context.
mb_paren :: LHsType GhcRn -> LHsType GhcRn
mb_paren lhs_ty@(L loc hs_ty)
| hsTypeNeedsParens maxPrec hs_ty = L loc (HsParTy noAnn lhs_ty)
| otherwise = lhs_ty
{- Note [Partial Type Splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Partial Type Signatures are partially supported in TH type splices: only
anonymous wild cards are allowed.
-- ToDo: SLPJ says: I don't understand all this
Normally, named wild cards are collected before renaming a (partial) type
signature. However, TH type splices are run during renaming, i.e. after the
initial traversal, leading to out of scope errors for named wild cards. We
can't just extend the initial traversal to collect the named wild cards in TH
type splices, as we'd need to expand them, which is supposed to happen only
once, during renaming.
Similarly, the extra-constraints wild card is handled right before renaming
too, and is therefore also not supported in a TH type splice. Another reason
to forbid extra-constraints wild cards in TH type splices is that a single
signature can contain many TH type splices, whereas it mustn't contain more
than one extra-constraints wild card. Enforcing would this be hard the way
things are currently organised.
Anonymous wild cards pose no problem, because they start out without names and
are given names during renaming. These names are collected right after
renaming. The names generated for anonymous wild cards in TH type splices will
thus be collected as well.
For more details about renaming wild cards, see GHC.Rename.HsType.rnHsSigWcType
Note that partial type signatures are fully supported in TH declaration
splices, e.g.:
[d| foo :: _ => _
foo x y = x == y |]
This is because in this case, the partial type signature can be treated as a
whole signature, instead of as an arbitrary type.
-}
----------------------
-- | Rename a splice pattern. See Note [rnSplicePat]
rnSplicePat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs))
, FreeVars)
rnSplicePat splice
= rnUntypedSpliceGen run_pat_splice pend_pat_splice splice
where
pend_pat_splice name rn_splice
= (makePending UntypedPatSplice name rn_splice
, (rn_splice, HsUntypedSpliceNested name)) -- Pat splice is nested and thus simply renamed
run_pat_splice rn_splice
= do { traceRn "rnSplicePat: untyped pattern splice" empty
; (pat, mod_finalizers) <-
runRnSplice UntypedPatSplice runMetaP ppr rn_splice
-- See Note [Delaying modFinalizers in untyped splices].
; let p = HsUntypedSpliceTop (ThModFinalizers mod_finalizers) pat
; return ((rn_splice, p), emptyFVs) }
-- Wrap the result of the quasi-quoter in parens so that we don't
-- lose the outermost location set by runQuasiQuote (#7918)
----------------------
rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
rnSpliceDecl (SpliceDecl _ (L loc splice) flg)
= rnUntypedSpliceGen run_decl_splice pend_decl_splice splice
where
pend_decl_splice name rn_splice
= ( makePending UntypedDeclSplice name rn_splice
, SpliceDecl noExtField (L loc rn_splice) flg)
run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (pprUntypedSplice True Nothing rn_splice)
rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
-- Declaration splice at the very top level of the module
rnTopSpliceDecls splice
= do { checkTopSpliceAllowed splice
; (rn_splice, fvs) <- checkNoErrs $
setStage (Splice Untyped) $
rnUntypedSplice splice
-- As always, be sure to checkNoErrs above lest we end up with
-- holes making it to typechecking, hence #12584.
--
-- Note that we cannot call checkNoErrs for the whole duration
-- of rnTopSpliceDecls. The reason is that checkNoErrs changes
-- the local environment to temporarily contain a new
-- reference to store errors, and add_mod_finalizers would
-- cause this reference to be stored after checkNoErrs finishes.
-- This is checked by test TH_finalizer.
; traceRn "rnTopSpliceDecls: untyped declaration splice" empty
; (decls, mod_finalizers) <- checkNoErrs $
runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
; add_mod_finalizers_now mod_finalizers
; return (decls,fvs) }
where
ppr_decls :: [LHsDecl GhcPs] -> SDoc
ppr_decls ds = vcat (map ppr ds)
-- Adds finalizers to the global environment instead of delaying them
-- to the type checker.
--
-- Declaration splices do not have an interesting local environment so
-- there is no point in delaying them.
--
-- See Note [Delaying modFinalizers in untyped splices].
add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()
add_mod_finalizers_now [] = return ()
add_mod_finalizers_now mod_finalizers = do
th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
env <- getLclEnv
updTcRef th_modfinalizers_var $ \fins ->
(env, ThModFinalizers mod_finalizers) : fins
{-
Note [rnSplicePat]
~~~~~~~~~~~~~~~~~~
Renaming a pattern splice is a bit tricky, because we need the variables
bound in the pattern to be in scope in the RHS of the pattern. This scope
management is effectively done by using continuation-passing style in
GHC.Rename.Pat, through the CpsRn monad. We don't wish to be in that monad here
(it would create import cycles and generally conflict with renaming other
splices), so we really want to return a (Pat GhcPs) -- the result of
running the splice -- which can then be further renamed in GHC.Rename.Pat, in
the CpsRn monad.
The problem is that if we're renaming a splice within a bracket, we
*don't* want to run the splice now. We really do just want to rename
it to an HsUntypedSplice Name. Of course, then we can't know what variables
are bound within the splice. So we accept any unbound variables and
rename them again when the bracket is spliced in. If a variable is brought
into scope by a pattern splice all is fine. If it is not then an error is
reported.
In any case, when we're done in rnSplicePat, we'll have both the renamed
splice, and either a Pat RdrName and ThModFinalizers (the result of running a
top-level splice) or a splice point name. Thus, rnSplicePat returns both
HsUntypedSplice GhcRn, and HsUntypedSpliceResult (Pat GhcPs) -- which models
the existence of either the result of running the splice (HsUntypedSpliceTop),
or its splice point name if nested (HsUntypedSpliceNested)
-}
spliceCtxt :: HsUntypedSplice GhcPs -> SDoc
spliceCtxt splice
= hang (text "In the" <+> what) 2 (pprUntypedSplice True Nothing splice)
where
what = case splice of
HsUntypedSpliceExpr {} -> text "untyped splice:"
HsQuasiQuote {} -> text "quasi-quotation:"
-- | The splice data to be logged
data SpliceInfo
= SpliceInfo
{ spliceDescription :: String
, spliceSource :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls
-- added by addTopDecls
, spliceIsDecl :: Bool -- True <=> put the generate code in a file
-- when -dth-dec-file is on
, spliceGenerated :: SDoc
}
-- Note that 'spliceSource' is *renamed* but not *typechecked*
-- Reason (a) less typechecking crap
-- (b) data constructors after type checking have been
-- changed to their *wrappers*, and that makes them
-- print always fully qualified
-- | outputs splice information for 2 flags which have different output formats:
-- `-ddump-splices` and `-dth-dec-file`
traceSplice :: SpliceInfo -> TcM ()
traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
, spliceGenerated = gen, spliceIsDecl = is_decl })
= do loc <- case mb_src of
Nothing -> getSrcSpanM
Just (L loc _) -> return (locA loc)
traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)
when is_decl $ do -- Raw material for -dth-dec-file
logger <- getLogger
liftIO $ putDumpFileMaybe logger Opt_D_th_dec_file "" FormatHaskell (spliceCodeDoc loc)
where
-- `-ddump-splices`
spliceDebugDoc :: SrcSpan -> SDoc
spliceDebugDoc loc
= let code = case mb_src of
Nothing -> ending
Just e -> nest 2 (ppr (stripParensLHsExpr e)) : ending
ending = [ text "======>", nest 2 gen ]
in hang (ppr loc <> colon <+> text "Splicing" <+> text sd)
2 (sep code)
-- `-dth-dec-file`
spliceCodeDoc :: SrcSpan -> SDoc
spliceCodeDoc loc
= vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
, gen ]
illegalTypedSplice :: TcRnMessage
illegalTypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $
text "Typed splices may not appear in untyped brackets"
illegalUntypedSplice :: TcRnMessage
illegalUntypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $
text "Untyped splices may not appear in typed brackets"
checkThLocalName :: Name -> RnM ()
checkThLocalName name
| isUnboundName name -- Do not report two errors for
= return () -- $(not_in_scope args)
| otherwise
= do { traceRn "checkThLocalName" (ppr name)
; mb_local_use <- getStageAndBindLevel name
; case mb_local_use of {
Nothing -> return () ; -- Not a locally-bound thing
Just (top_lvl, bind_lvl, use_stage) ->
do { let use_lvl = thLevel use_stage
; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl
; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl
<+> ppr use_stage
<+> ppr use_lvl)
; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }
--------------------------------------
checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel
-> Name -> TcM ()
-- We are inside brackets, and (use_lvl > bind_lvl)
-- Now we must check whether there's a cross-stage lift to do
-- Examples \x -> [| x |]
-- [| map |]
--
-- This code is similar to checkCrossStageLifting in GHC.Tc.Gen.Expr, but
-- this is only run on *untyped* brackets.
checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name
| Brack _ (RnPendingUntyped ps_var) <- use_stage -- Only for untyped brackets
, use_lvl > bind_lvl -- Cross-stage condition
= check_cross_stage_lifting top_lvl name ps_var
| otherwise
= return ()
check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
check_cross_stage_lifting top_lvl name ps_var
| isTopLevel top_lvl
-- Top-level identifiers in this module,
-- (which have External Names)
-- are just like the imported case:
-- no need for the 'lifting' treatment
-- E.g. this is fine:
-- f x = x
-- g y = [| f 3 |]
= when (isExternalName name) (keepAlive name)
-- See Note [Keeping things alive for Template Haskell]
| otherwise
= -- Nested identifiers, such as 'x' in
-- E.g. \x -> [| h x |]
-- We must behave as if the reference to x was
-- h $(lift x)
-- We use 'x' itself as the SplicePointName, used by
-- the desugarer to stitch it all back together.
-- If 'x' occurs many times we may get many identical
-- bindings of the same SplicePointName, but that doesn't
-- matter, although it's a mite untidy.
do { traceRn "checkCrossStageLifting" (ppr name)
-- Construct the (lift x) expression
; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name)
pend_splice = PendingRnSplice UntypedExpSplice name lift_expr
-- Warning for implicit lift (#17804)
; addDetailedDiagnostic (TcRnImplicitLift name)
-- Update the pending splices
; ps <- readMutVar ps_var
; writeMutVar ps_var (pend_splice : ps) }
{-
Note [Keeping things alive for Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f x = x+1
g y = [| f 3 |]
Here 'f' is referred to from inside the bracket, which turns into data
and mentions only f's *name*, not 'f' itself. So we need some other
way to keep 'f' alive, lest it get dropped as dead code. That's what
keepAlive does. It puts it in the keep-alive set, which subsequently
ensures that 'f' stays as a top level binding.
This must be done by the renamer, not the type checker (as of old),
because the type checker doesn't typecheck the body of untyped
brackets (#8540).
A thing can have a bind_lvl of outerLevel, but have an internal name:
foo = [d| op = 3
bop = op + 1 |]
Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is
bound inside a bracket. That is because we don't even record
binding levels for top-level things; the binding levels are in the
LocalRdrEnv.
So the occurrence of 'op' in the rhs of 'bop' looks a bit like a
cross-stage thing, but it isn't really. And in fact we never need
to do anything here for top-level bound things, so all is fine, if
a bit hacky.
For these chaps (which have Internal Names) we don't want to put
them in the keep-alive set.
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. GHC.Tc.Gen.Expr.thBrackId). So, after incrementing
the use-level to account for the brackets, the cases are:
bind > use Error
bind = use+1 OK
bind < use
Imported things OK
Top-level things OK
Non-top-level Error
where 'use' is the binding level of the 'n quote. (So inside the implied
bracket the level would be use+1.)
Examples:
f 'map -- OK; also for top-level defns of this module
\x. f 'x -- Not ok (bind = 1, use = 1)
-- (whereas \x. f [| x |] might have been ok, by
-- cross-stage lifting
\y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)
[| \x. $(f 'x) |] -- OK (bind = 2, use = 1)
-}
|