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
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
|
-- (c) The University of Glasgow 2006
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an
-- orphan
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module Language.Haskell.Syntax.Extension
{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Utils.Env(
TyThing(..), TcTyThing(..), TcId,
-- Instance environment, and InstInfo type
InstInfo(..), iDFunId, pprInstInfoDetails,
simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
InstBindings(..),
-- Global environment
tcExtendGlobalEnv, tcExtendTyConEnv,
tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
tcExtendGlobalValEnv, tcTyThBinders,
tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
tcLookupTyCon, tcLookupClass,
tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass, tcLookupAxiom,
lookupGlobal, ioLookupDataCon,
addTypecheckedBinds,
-- Local environment
tcExtendKindEnv, tcExtendKindEnvList,
tcExtendTyVarEnv, tcExtendNameTyVarEnv,
tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcExtendBinderStack, tcExtendLocalTypeEnv,
isTypeClosedLetBndr,
tcCheckUsage,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
tcLookupTcTyCon,
tcLookupLcl_maybe,
getInLocalScope,
wrongThingErr, pprBinders,
tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
getTypeSigNames,
tcExtendRecEnv, -- For knot-tying
-- Tidying
tcInitTidyEnv, tcInitOpenTidyEnv,
-- Instances
tcLookupInstance, tcGetInstEnvs,
-- Rules
tcExtendRules,
-- Defaults
tcGetDefaultTys,
-- Template Haskell stuff
checkWellStaged, tcMetaTy, thLevel,
topIdLvl, isBrackStage,
-- New Ids
newDFunName,
newFamInstTyConName, newFamInstAxiomName,
mkStableIdFromString, mkStableIdFromName,
mkWrapperName
) where
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Runtime.Context
import GHC.Hs
import GHC.Iface.Env
import GHC.Iface.Load
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper)
import {-# SOURCE #-} GHC.Tc.Utils.Unify ( tcSubMult )
import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) )
import GHC.Core.UsageEnv
import GHC.Core.InstEnv
import GHC.Core.DataCon ( DataCon, flSelector )
import GHC.Core.PatSyn ( PatSyn )
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Coercion.Axiom
import GHC.Core.Class
import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Unit.External
import GHC.Unit.Env
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Encoding
import GHC.Utils.Misc ( HasDebugCallStack )
import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Data.List.SetOps
import GHC.Data.Maybe( MaybeErr(..), orElse )
import GHC.Types.SrcLoc
import GHC.Types.Basic hiding( SuccessFlag(..) )
import GHC.Types.TypeEnv
import GHC.Types.SourceFile
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.Id
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Name.Reader
import GHC.Types.TyThing
import GHC.Types.Error
import qualified GHC.LanguageExtensions as LangExt
import Data.IORef
import Data.List (intercalate)
import Control.Monad
import GHC.Driver.Env.KnotVars
{- *********************************************************************
* *
An IO interface to looking up globals
* *
********************************************************************* -}
lookupGlobal :: HscEnv -> Name -> IO TyThing
-- A variant of lookupGlobal_maybe for the clients which are not
-- interested in recovering from lookup failure and accept panic.
lookupGlobal hsc_env name
= do {
mb_thing <- lookupGlobal_maybe hsc_env name
; case mb_thing of
Succeeded thing -> return thing
Failed msg -> pprPanic "lookupGlobal" msg
}
lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
-- This may look up an Id that one has previously looked up.
-- If so, we are going to read its interface file, and add its bindings
-- to the ExternalPackageTable.
lookupGlobal_maybe hsc_env name
= do { -- Try local envt
let mod = icInteractiveModule (hsc_IC hsc_env)
mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
tcg_semantic_mod = homeModuleInstantiation mhome_unit mod
; if nameIsLocalOrFrom tcg_semantic_mod name
then (return
(Failed (text "Can't find local name: " <+> ppr name)))
-- Internal names can happen in GHCi
else
-- Try home package table and external package table
lookupImported_maybe hsc_env name
}
lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
-- Returns (Failed err) if we can't find the interface file for the thing
lookupImported_maybe hsc_env name
= do { mb_thing <- lookupType hsc_env name
; case mb_thing of
Just thing -> return (Succeeded thing)
Nothing -> importDecl_maybe hsc_env name
}
importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
importDecl_maybe hsc_env name
| Just thing <- wiredInNameTyThing_maybe name
= do { when (needWiredInHomeIface thing)
(initIfaceLoad hsc_env (loadWiredInHomeIface name))
-- See Note [Loading instances for wired-in things]
; return (Succeeded thing) }
| otherwise
= initIfaceLoad hsc_env (importDecl name)
ioLookupDataCon :: HscEnv -> Name -> IO DataCon
ioLookupDataCon hsc_env name = do
mb_thing <- ioLookupDataCon_maybe hsc_env name
case mb_thing of
Succeeded thing -> return thing
Failed msg -> pprPanic "lookupDataConIO" msg
ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon)
ioLookupDataCon_maybe hsc_env name = do
thing <- lookupGlobal hsc_env name
return $ case thing of
AConLike (RealDataCon con) -> Succeeded con
_ -> Failed $
pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
text "used as a data constructor"
addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
addTypecheckedBinds tcg_env binds
| isHsBootOrSig (tcg_src tcg_env) = tcg_env
-- Do not add the code for record-selector bindings
-- when compiling hs-boot files
| otherwise = tcg_env { tcg_binds = foldr unionBags
(tcg_binds tcg_env)
binds }
{-
************************************************************************
* *
* tcLookupGlobal *
* *
************************************************************************
Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
unless you know that the SrcSpan in the monad is already set to the
span of the Name.
-}
tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing
-- c.f. GHC.IfaceToCore.tcIfaceGlobal
tcLookupLocatedGlobal name
= addLocMA tcLookupGlobal name
tcLookupGlobal :: Name -> TcM TyThing
-- The Name is almost always an ExternalName, but not always
-- In GHCi, we may make command-line bindings (ghci> let x = True)
-- that bind a GlobalId, but with an InternalName
tcLookupGlobal name
= do { -- Try local envt
env <- getGblEnv
; case lookupNameEnv (tcg_type_env env) name of {
Just thing -> return thing ;
Nothing ->
-- Should it have been in the local envt?
-- (NB: use semantic mod here, since names never use
-- identity module, see Note [Identity versus semantic module].)
if nameIsLocalOrFrom (tcg_semantic_mod env) name
then notFound name -- Internal names can happen in GHCi
else
-- Try home package table and external package table
do { mb_thing <- tcLookupImported_maybe name
; case mb_thing of
Succeeded thing -> return thing
Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg)
}}}
-- Look up only in this module's global env't. Don't look in imports, etc.
-- Panic if it's not there.
tcLookupGlobalOnly :: Name -> TcM TyThing
tcLookupGlobalOnly name
= do { env <- getGblEnv
; return $ case lookupNameEnv (tcg_type_env env) name of
Just thing -> thing
Nothing -> pprPanic "tcLookupGlobalOnly" (ppr name) }
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon name = do
thing <- tcLookupGlobal name
case thing of
AConLike (RealDataCon con) -> return con
_ -> wrongThingErr "data constructor" (AGlobal thing) name
tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn name = do
thing <- tcLookupGlobal name
case thing of
AConLike (PatSynCon ps) -> return ps
_ -> wrongThingErr "pattern synonym" (AGlobal thing) name
tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike name = do
thing <- tcLookupGlobal name
case thing of
AConLike cl -> return cl
_ -> wrongThingErr "constructor-like thing" (AGlobal thing) name
tcLookupClass :: Name -> TcM Class
tcLookupClass name = do
thing <- tcLookupGlobal name
case thing of
ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
_ -> wrongThingErr "class" (AGlobal thing) name
tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon name = do
thing <- tcLookupGlobal name
case thing of
ATyCon tc -> return tc
_ -> wrongThingErr "type constructor" (AGlobal thing) name
tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom name = do
thing <- tcLookupGlobal name
case thing of
ACoAxiom ax -> return ax
_ -> wrongThingErr "axiom" (AGlobal thing) name
tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
tcLookupLocatedGlobalId = addLocMA tcLookupId
tcLookupLocatedClass :: LocatedA Name -> TcM Class
tcLookupLocatedClass = addLocMA tcLookupClass
tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
tcLookupLocatedTyCon = addLocMA tcLookupTyCon
-- Find the instance that exactly matches a type class application. The class arguments must be precisely
-- the same as in the instance declaration (modulo renaming & casts).
--
tcLookupInstance :: Class -> [Type] -> TcM ClsInst
tcLookupInstance cls tys
= do { instEnv <- tcGetInstEnvs
; case lookupUniqueInstEnv instEnv cls tys of
Left err ->
failWithTc $ TcRnUnknownMessage
$ mkPlainError noHints (text "Couldn't match instance:" <+> err)
Right (inst, tys)
| uniqueTyVars tys -> return inst
| otherwise -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints errNotExact)
}
where
errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
uniqueTyVars tys = all isTyVarTy tys
&& hasNoDups (map (getTyVar "tcLookupInstance") tys)
tcGetInstEnvs :: TcM InstEnvs
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
tcGetInstEnvs = do { eps <- getEps
; env <- getGblEnv
; return (InstEnvs { ie_global = eps_inst_env eps
, ie_local = tcg_inst_env env
, ie_visible = tcVisibleOrphanMods env }) }
instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
lookupThing = tcLookupGlobal
{-
************************************************************************
* *
Extending the global environment
* *
************************************************************************
-}
setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
-- Use this to update the global type env
-- It updates both * the normal tcg_type_env field
-- * the tcg_type_env_var field seen by interface files
setGlobalTypeEnv tcg_env new_type_env
= do { -- Sync the type-envt variable seen by interface files
; case lookupKnotVars (tcg_type_env_var tcg_env) (tcg_mod tcg_env) of
Just tcg_env_var -> writeMutVar tcg_env_var new_type_env
Nothing -> return ()
; return (tcg_env { tcg_type_env = new_type_env }) }
tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
-- Just extend the global environment with some TyThings
-- Do not extend tcg_tcs, tcg_patsyns etc
tcExtendGlobalEnvImplicit things thing_inside
= do { tcg_env <- getGblEnv
; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things
; tcg_env' <- setGlobalTypeEnv tcg_env ge'
; setGblEnv tcg_env' thing_inside }
tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
-- Given a mixture of Ids, TyCons, Classes, all defined in the
-- module being compiled, extend the global environment
tcExtendGlobalEnv things thing_inside
= do { env <- getGblEnv
; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
; setGblEnv env' $
tcExtendGlobalEnvImplicit things thing_inside
}
tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
-- Given a mixture of Ids, TyCons, Classes, all defined in the
-- module being compiled, extend the global environment
tcExtendTyConEnv tycons thing_inside
= do { env <- getGblEnv
; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }
; setGblEnv env' $
tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
}
-- Given a [TyThing] of "non-value" bindings coming from type decls
-- (constructors, field selectors, class methods) return their
-- TH binding levels (to be added to a LclEnv).
-- See GHC ticket #17820 .
tcTyThBinders :: [TyThing] -> TcM ThBindEnv
tcTyThBinders implicit_things = do
stage <- getStage
let th_lvl = thLevel stage
th_bndrs = mkNameEnv
[ ( n , (TopLevel, th_lvl) ) | n <- names ]
return th_bndrs
where
names = concatMap get_names implicit_things
get_names (AConLike acl) =
conLikeName acl : map flSelector (conLikeFieldLabels acl)
get_names (AnId i) = [idName i]
get_names _ = []
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
-- Same deal as tcExtendGlobalEnv, but for Ids
tcExtendGlobalValEnv ids thing_inside
= tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
-- Extend the global environments for the type/class knot tying game
-- Just like tcExtendGlobalEnv, except the argument is a list of pairs
tcExtendRecEnv gbl_stuff thing_inside
= do { tcg_env <- getGblEnv
; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
tcg_env' = tcg_env { tcg_type_env = ge' }
-- No need for setGlobalTypeEnv (which side-effects the
-- tcg_type_env_var); tcExtendRecEnv is used just
-- when kind-check a group of type/class decls. It would
-- in any case be wrong for an interface-file decl to end up
-- with a TcTyCon in it!
; setGblEnv tcg_env' thing_inside }
{-
************************************************************************
* *
\subsection{The local environment}
* *
************************************************************************
-}
tcLookupLocated :: LocatedA Name -> TcM TcTyThing
tcLookupLocated = addLocMA tcLookup
tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe name
= do { local_env <- getLclTypeEnv
; return (lookupNameEnv local_env name) }
tcLookup :: Name -> TcM TcTyThing
tcLookup name = do
local_env <- getLclTypeEnv
case lookupNameEnv local_env name of
Just thing -> return thing
Nothing -> (AGlobal <$> tcLookupGlobal name)
tcLookupTyVar :: Name -> TcM TcTyVar
tcLookupTyVar name
= do { thing <- tcLookup name
; case thing of
ATyVar _ tv -> return tv
_ -> pprPanic "tcLookupTyVar" (ppr name) }
tcLookupId :: Name -> TcM Id
-- Used when we aren't interested in the binding level, nor refinement.
-- The "no refinement" part means that we return the un-refined Id regardless
--
-- The Id is never a DataCon. (Why does that matter? see GHC.Tc.Gen.Expr.tcId)
tcLookupId name = do
thing <- tcLookupIdMaybe name
case thing of
Just id -> return id
_ -> pprPanic "tcLookupId" (ppr name)
tcLookupIdMaybe :: Name -> TcM (Maybe Id)
tcLookupIdMaybe name
= do { thing <- tcLookup name
; case thing of
ATcId { tct_id = id} -> return $ Just id
AGlobal (AnId id) -> return $ Just id
_ -> return Nothing }
tcLookupLocalIds :: [Name] -> TcM [TcId]
-- We expect the variables to all be bound, and all at
-- the same level as the lookup. Only used in one place...
tcLookupLocalIds ns
= do { env <- getLclEnv
; return (map (lookup (tcl_env env)) ns) }
where
lookup lenv name
= case lookupNameEnv lenv name of
Just (ATcId { tct_id = id }) -> id
_ -> pprPanic "tcLookupLocalIds" (ppr name)
-- inferInitialKind has made a suitably-shaped kind for the type or class
-- Look it up in the local environment. This is used only for tycons
-- that we're currently type-checking, so we're sure to find a TcTyCon.
tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon
tcLookupTcTyCon name = do
thing <- tcLookup name
case thing of
ATcTyCon tc -> return tc
_ -> pprPanic "tcLookupTcTyCon" (ppr name)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope = do { lcl_env <- getLclTypeEnv
; return (`elemNameEnv` lcl_env) }
tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
-- Used only during kind checking, for TcThings that are
-- ATcTyCon or APromotionErr
-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
tcExtendKindEnvList things thing_inside
= do { traceTc "tcExtendKindEnvList" (ppr things)
; updLclEnv upd_env thing_inside }
where
upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
-- A variant of tcExtendKindEvnList
tcExtendKindEnv extra_env thing_inside
= do { traceTc "tcExtendKindEnv" (ppr extra_env)
; updLclEnv upd_env thing_inside }
where
upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }
-----------------------
-- Scoped type and kind variables
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
= tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside
tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv binds thing_inside
-- this should be used only for explicitly mentioned scoped variables.
-- thus, no coercion variables
= tc_extend_local_env NotTopLevel names $
tcExtendBinderStack tv_binds $
thing_inside
where
tv_binds :: [TcBinder]
tv_binds = [TcTvBndr name tv | (name,tv) <- binds]
names = [(name, ATyVar name tv) | (name, tv) <- binds]
isTypeClosedLetBndr :: Id -> Bool
-- See Note [Bindings with closed types] in GHC.Tc.Types
isTypeClosedLetBndr = noFreeVarsOfType . idType
tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
-- Used for binding the recursive uses of Ids in a binding
-- both top-level value bindings and nested let/where-bindings
-- Does not extend the TcBinderStack
tcExtendRecIds pairs thing_inside
= tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = let_id
, tct_info = NonClosedLet emptyNameSet False })
| (name, let_id) <- pairs ] $
thing_inside
tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
-- Used for binding the Ids that have a complete user type signature
-- Does not extend the TcBinderStack
tcExtendSigIds top_lvl sig_ids thing_inside
= tc_extend_local_env top_lvl
[ (idName id, ATcId { tct_id = id
, tct_info = info })
| id <- sig_ids
, let closed = isTypeClosedLetBndr id
info = NonClosedLet emptyNameSet closed ]
thing_inside
tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
-> [TcId] -> TcM a -> TcM a
-- Used for both top-level value bindings and nested let/where-bindings
-- Adds to the TcBinderStack too
tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
ids thing_inside
= tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $
tc_extend_local_env top_lvl
[ (idName id, ATcId { tct_id = id
, tct_info = mk_tct_info id })
| id <- ids ]
thing_inside
where
mk_tct_info id
| type_closed && isEmptyNameSet rhs_fvs = ClosedLet
| otherwise = NonClosedLet rhs_fvs type_closed
where
name = idName id
rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet
type_closed = isTypeClosedLetBndr id &&
(fv_type_closed || hasCompleteSig sig_fn name)
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
-- For lambda-bound and case-bound Ids
-- Extends the TcBinderStack as well
tcExtendIdEnv ids thing_inside
= tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair
tcExtendIdEnv1 name id thing_inside
= tcExtendIdEnv2 [(name,id)] thing_inside
tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
tcExtendIdEnv2 names_w_ids thing_inside
= tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
| (_,mono_id) <- names_w_ids ] $
tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = id
, tct_info = NotLetBound })
| (name,id) <- names_w_ids]
thing_inside
tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env top_lvl extra_env thing_inside
-- Precondition: the argument list extra_env has TcTyThings
-- that ATcId or ATyVar, but nothing else
--
-- Invariant: the ATcIds are fully zonked. Reasons:
-- (a) The kinds of the forall'd type variables are defaulted
-- (see Kind.defaultKind, done in skolemiseQuantifiedTyVar)
-- (b) There are no via-Indirect occurrences of the bound variables
-- in the types, because instantiation does not look through such things
-- (c) The call to tyCoVarsOfTypes is ok without looking through refs
-- The second argument of type TyVarSet is a set of type variables
-- that are bound together with extra_env and should not be regarded
-- as free in the types of extra_env.
= do { traceTc "tc_extend_local_env" (ppr extra_env)
; stage <- getStage
; env0@(TcLclEnv { tcl_rdr = rdr_env
, tcl_th_bndrs = th_bndrs
, tcl_env = lcl_type_env }) <- getLclEnv
; let thlvl = (top_lvl, thLevel stage)
env1 = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env
[ n | (n, _) <- extra_env, isInternalName n ]
-- The LocalRdrEnv contains only non-top-level names
-- (GlobalRdrEnv handles the top level)
, tcl_th_bndrs = extendNameEnvList th_bndrs
[(n, thlvl) | (n, ATcId {}) <- extra_env]
-- We only track Ids in tcl_th_bndrs
, tcl_env = extendNameEnvList lcl_type_env extra_env }
-- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and
-- Template Haskell staging env simultaneously. Reason for extending
-- LocalRdrEnv: after running a TH splice we need to do renaming.
; setLclEnv env1 thing_inside }
tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv
tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
= lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things }
-- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the
-- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the
-- usage environment. See also Note [Wrapper returned from tcSubMult] in
-- GHC.Tc.Utils.Unify, which applies to the wrapper returned from this function.
tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper)
tcCheckUsage name id_mult thing_inside
= do { (local_usage, result) <- tcCollectingUsage thing_inside
; wrapper <- check_then_add_usage local_usage
; return (result, wrapper) }
where
check_then_add_usage :: UsageEnv -> TcM HsWrapper
-- Checks that the usage of the newly introduced binder is compatible with
-- its multiplicity, and combines the usage of non-new binders to |uenv|
check_then_add_usage uenv
= do { let actual_u = lookupUE uenv name
; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u)
; wrapper <- case actual_u of
Bottom -> return idHsWrapper
Zero -> tcSubMult (UsageEnvironmentOf name) Many id_mult
MUsage m -> do { m <- promote_mult m
; tcSubMult (UsageEnvironmentOf name) m id_mult }
; tcEmitBindingUsage (deleteUE uenv name)
; return wrapper }
-- This is gross. The problem is in test case typecheck/should_compile/T18998:
-- f :: a %1-> Id n a -> Id n a
-- f x (MkId _) = MkId x
-- where MkId is a GADT constructor. Multiplicity polymorphism of constructors
-- invents a new multiplicity variable p[2] for the application MkId x. This
-- variable is at level 2, bumped because of the GADT pattern-match (MkId _).
-- We eventually unify the variable with One, due to the call to tcSubMult in
-- tcCheckUsage. But by then, we're at TcLevel 1, and so the level-check
-- fails.
--
-- What to do? If we did inference "for real", the sub-multiplicity constraint
-- would end up in the implication of the GADT pattern-match, and all would
-- be well. But we don't have a real sub-multiplicity constraint to put in
-- the implication. (Multiplicity inference works outside the usual generate-
-- constraints-and-solve scheme.) Here, where the multiplicity arrives, we
-- must promote all multiplicity variables to reflect this outer TcLevel.
-- It's reminiscent of floating a constraint, really, so promotion is
-- appropriate. The promoteTcType function works only on types of kind TYPE rr,
-- so we can't use it here. Thus, this dirtiness.
--
-- It works nicely in practice.
--
-- We use a set to avoid calling promoteMetaTyVarTo twice on the same
-- metavariable. This happened in #19400.
promote_mult m = do { fvs <- zonkTyCoVarsAndFV (tyCoVarsOfType m)
; any_promoted <- promoteTyVarSet fvs
; if any_promoted then zonkTcType m else return m
}
{- *********************************************************************
* *
The TcBinderStack
* *
********************************************************************* -}
tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack bndrs thing_inside
= do { traceTc "tcExtendBinderStack" (ppr bndrs)
; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
thing_inside }
tcInitTidyEnv :: TcM TidyEnv
-- We initialise the "tidy-env", used for tidying types before printing,
-- by building a reverse map from the in-scope type variables to the
-- OccName that the programmer originally used for them
tcInitTidyEnv
= do { lcl_env <- getLclEnv
; go emptyTidyEnv (tcl_bndrs lcl_env) }
where
go (env, subst) []
= return (env, subst)
go (env, subst) (b : bs)
| TcTvBndr name tyvar <- b
= do { let (env', occ') = tidyOccName env (nameOccName name)
name' = tidyNameOcc name occ'
tyvar1 = setTyVarName tyvar name'
; tyvar2 <- zonkTcTyVarToTyVar tyvar1
-- Be sure to zonk here! Tidying applies to zonked
-- types, so if we don't zonk we may create an
-- ill-kinded type (#14175)
; go (env', extendVarEnv subst tyvar tyvar2) bs }
| otherwise
= go (env, subst) bs
-- | Get a 'TidyEnv' that includes mappings for all vars free in the given
-- type. Useful when tidying open types.
tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
tcInitOpenTidyEnv tvs
= do { env1 <- tcInitTidyEnv
; let env2 = tidyFreeTyCoVars env1 tvs
; return env2 }
{- *********************************************************************
* *
Adding placeholders
* *
********************************************************************* -}
tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
-- See Note [AFamDataCon: not promoting data family constructors]
tcAddDataFamConPlaceholders inst_decls thing_inside
= tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)
| lid <- inst_decls, con <- get_cons lid ]
thing_inside
-- Note [AFamDataCon: not promoting data family constructors]
where
-- get_cons extracts the *constructor* bindings of the declaration
get_cons :: LInstDecl GhcRn -> [Name]
get_cons (L _ (TyFamInstD {})) = []
get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
= concatMap (get_fi_cons . unLoc) fids
get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
get_fi_cons (DataFamInstDecl { dfid_eqn =
FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }})
= map unLoc $ concatMap (getConNames . unLoc) cons
tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
-- See Note [Don't promote pattern synonyms]
tcAddPatSynPlaceholders pat_syns thing_inside
= tcExtendKindEnvList [ (name, APromotionErr PatSynPE)
| PSB{ psb_id = L _ name } <- pat_syns ]
thing_inside
getTypeSigNames :: [LSig GhcRn] -> NameSet
-- Get the names that have a user type sig
getTypeSigNames sigs
= foldr get_type_sig emptyNameSet sigs
where
get_type_sig :: LSig GhcRn -> NameSet -> NameSet
get_type_sig sig ns =
case sig of
L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names)
L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names)
_ -> ns
{- Note [AFamDataCon: not promoting data family constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data family T a
data instance T Int = MkT
data Proxy (a :: k)
data S = MkS (Proxy 'MkT)
Is it ok to use the promoted data family instance constructor 'MkT' in
the data declaration for S (where both declarations live in the same module)?
No, we don't allow this. It *might* make sense, but at least it would mean that
we'd have to interleave typechecking instances and data types, whereas at
present we do data types *then* instances.
So to check for this we put in the TcLclEnv a binding for all the family
constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
type checking 'S' we'll produce a decent error message.
#12088 describes this limitation. Of course, when MkT and S live in
different modules then all is well.
Note [Don't promote pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We never promote pattern synonyms.
Consider this (#11265):
pattern A = True
instance Eq A
We want a civilised error message from the occurrence of 'A'
in the instance, yet 'A' really has not yet been type checked.
Similarly (#9161)
{-# LANGUAGE PatternSynonyms, DataKinds #-}
pattern A = ()
b :: A
b = undefined
Here, the type signature for b mentions A. But A is a pattern
synonym, which is typechecked as part of a group of bindings (for very
good reasons; a view pattern in the RHS may mention a value binding).
It is entirely reasonable to reject this, but to do so we need A to be
in the kind environment when kind-checking the signature for B.
Hence tcAddPatSynPlaceholers adds a binding
A -> APromotionErr PatSynPE
to the environment. Then GHC.Tc.Gen.HsType.tcTyVar will find A in the kind
environment, and will give a 'wrongThingErr' as a result. But the
lookup of A won't fail.
************************************************************************
* *
\subsection{Rules}
* *
************************************************************************
-}
tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a
-- Just pop the new rules into the EPS and envt resp
-- All the rules come from an interface file, not source
-- Nevertheless, some may be for this module, if we read
-- its interface instead of its source code
tcExtendRules lcl_rules thing_inside
= do { env <- getGblEnv
; let
env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
; setGblEnv env' thing_inside }
{-
************************************************************************
* *
Meta level
* *
************************************************************************
-}
checkWellStaged :: SDoc -- What the stage check is for
-> ThLevel -- Binding level (increases inside brackets)
-> ThLevel -- Use stage
-> TcM () -- Fail if badly staged, adding an error
checkWellStaged pp_thing bind_lvl use_lvl
| use_lvl >= bind_lvl -- OK! Used later than bound
= return () -- E.g. \x -> [| $(f x) |]
| bind_lvl == outerLevel -- GHC restriction on top level splices
= stageRestrictionError pp_thing
| otherwise -- Badly staged
= failWithTc $ -- E.g. \x -> $(f x)
TcRnUnknownMessage $ mkPlainError noHints $
text "Stage error:" <+> pp_thing <+>
hsep [text "is bound at stage" <+> ppr bind_lvl,
text "but used at stage" <+> ppr use_lvl]
stageRestrictionError :: SDoc -> TcM a
stageRestrictionError pp_thing
= failWithTc $
TcRnUnknownMessage $ mkPlainError noHints $
sep [ text "GHC stage restriction:"
, nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
, text "and must be imported, not defined locally"])]
topIdLvl :: Id -> ThLevel
-- Globals may either be imported, or may be from an earlier "chunk"
-- (separated by declaration splices) of this module. The former
-- *can* be used inside a top-level splice, but the latter cannot.
-- Hence we give the former impLevel, but the latter topLevel
-- E.g. this is bad:
-- x = [| foo |]
-- $( f x )
-- By the time we are processing the $(f x), the binding for "x"
-- will be in the global env, not the local one.
topIdLvl id | isLocalId id = outerLevel
| otherwise = impLevel
tcMetaTy :: Name -> TcM Type
-- Given the name of a Template Haskell data type,
-- return the type
-- E.g. given the name "Expr" return the type "Expr"
tcMetaTy tc_name = do
t <- tcLookupTyCon tc_name
return (mkTyConTy t)
isBrackStage :: ThStage -> Bool
isBrackStage (Brack {}) = True
isBrackStage _other = False
{-
************************************************************************
* *
getDefaultTys
* *
************************************************************************
-}
tcGetDefaultTys :: TcM ([Type], -- Default types
(Bool, -- True <=> Use overloaded strings
Bool)) -- True <=> Use extended defaulting rules
tcGetDefaultTys
= do { dflags <- getDynFlags
; let ovl_strings = xopt LangExt.OverloadedStrings dflags
extended_defaults = xopt LangExt.ExtendedDefaultRules dflags
-- See also #1974
flags = (ovl_strings, extended_defaults)
; mb_defaults <- getDeclaredDefaultTys
; case mb_defaults of {
Just tys -> return (tys, flags) ;
-- User-supplied defaults
Nothing -> do
-- No use-supplied default
-- Use [Integer, Double], plus modifications
{ integer_ty <- tcMetaTy integerTyConName
; list_ty <- tcMetaTy listTyConName
; checkWiredInTyCon doubleTyCon
; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
-- Note [Extended defaults]
++ [integer_ty, doubleTy]
++ opt_deflt ovl_strings [stringTy]
; return (deflt_tys, flags) } } }
where
opt_deflt True xs = xs
opt_deflt False _ = []
{-
Note [Extended defaults]
~~~~~~~~~~~~~~~~~~~~~
In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we
try when defaulting. This has very little real impact, except in the following case.
Consider:
Text.Printf.printf "hello"
This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't
want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to
default the 'a' to (), rather than to Integer (which is what would otherwise happen;
and then GHCi doesn't attempt to print the (). So in interactive mode, we add
() to the list of defaulting types. See #1200.
Additionally, the list type [] is added as a default specialization for
Traversable and Foldable. As such the default default list now has types of
varying kinds, e.g. ([] :: * -> *) and (Integer :: *).
************************************************************************
* *
\subsection{The InstInfo type}
* *
************************************************************************
The InstInfo type summarises the information in an instance declaration
instance c => k (t tvs) where b
It is used just for *local* instance decls (not ones from interface files).
But local instance decls includes
- derived ones
- generic ones
as well as explicit user written ones.
-}
data InstInfo a
= InstInfo
{ iSpec :: ClsInst -- Includes the dfun id
, iBinds :: InstBindings a
}
iDFunId :: InstInfo a -> DFunId
iDFunId info = instanceDFunId (iSpec info)
data InstBindings a
= InstBindings
{ ib_tyvars :: [Name] -- Names of the tyvars from the instance head
-- that are lexically in scope in the bindings
-- Must correspond 1-1 with the forall'd tyvars
-- of the dfun Id. When typechecking, we are
-- going to extend the typechecker's envt with
-- ib_tyvars -> dfun_forall_tyvars
, ib_binds :: LHsBinds a -- Bindings for the instance methods
, ib_pragmas :: [LSig a] -- User pragmas recorded for generating
-- specialised instances
, ib_extensions :: [LangExt.Extension] -- Any extra extensions that should
-- be enabled when type-checking
-- this instance; needed for
-- GeneralizedNewtypeDeriving
, ib_derived :: Bool
-- True <=> This code was generated by GHC from a deriving clause
-- or standalone deriving declaration
-- Used only to improve error messages
}
instance (OutputableBndrId a)
=> Outputable (InstInfo (GhcPass a)) where
ppr = pprInstInfoDetails
pprInstInfoDetails :: (OutputableBndrId a)
=> InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails info
= hang (pprInstanceHdr (iSpec info) <+> text "where")
2 (details (iBinds info))
where
details (InstBindings { ib_pragmas = p, ib_binds = b }) =
pprDeclList (pprLHsBindsForUser b p)
simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
(_, cls, [ty]) -> (cls, ty)
_ -> panic "simpleInstInfoClsTy"
simpleInstInfoTy :: InstInfo a -> Type
simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
simpleInstInfoTyCon :: InstInfo a -> TyCon
-- Gets the type constructor for a simple instance declaration,
-- i.e. one of the form instance (...) => C (T a b c) where ...
simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
-- | Make a name for the dict fun for an instance decl. It's an *external*
-- name, like other top-level names, and hence must be made with
-- newGlobalBinder.
newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
newDFunName clas tys loc
= do { is_boot <- tcIsHsBootOrSig
; mod <- getModule
; let info_string = occNameString (getOccName clas) ++
concatMap (occNameString.getDFunTyKey) tys
; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
; newGlobalBinder mod dfun_occ loc }
newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name
newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locA loc) name [tys]
newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name
newFamInstAxiomName (L loc name) branches
= mk_fam_inst_name mkInstTyCoOcc (locA loc) name branches
mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name adaptOcc loc tc_name tyss
= do { mod <- getModule
; let info_string = occNameString (getOccName tc_name) ++
intercalate "|" ty_strings
; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
; newGlobalBinder mod (adaptOcc occ) loc }
where
ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
{-
Stable names used for foreign exports and annotations.
For stable names, the name must be unique (see #1533). If the
same thing has several stable Ids based on it, the
top-level bindings generated must not have the same name.
Hence we create an External name (doesn't change), and we
append a Unique to the string right here.
-}
mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
mkStableIdFromString str sig_ty loc occ_wrapper = do
uniq <- newUnique
mod <- getModule
nextWrapperNum <- tcg_next_wrapper_num <$> getGblEnv
name <- mkWrapperName nextWrapperNum "stable" str
let occ = mkVarOccFS name :: OccName
gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
id = mkExportedVanillaId gnm sig_ty :: Id
return id
mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
mkWrapperName :: (MonadIO m, HasModule m)
=> IORef (ModuleEnv Int) -> String -> String -> m FastString
-- ^ @mkWrapperName ref what nameBase@
--
-- See Note [Generating fresh names for ccall wrapper] for @ref@'s purpose.
mkWrapperName wrapperRef what nameBase
= do thisMod <- getModule
let pkg = unitString (moduleUnit thisMod)
mod = moduleNameString (moduleName thisMod)
wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
mod_env' = extendModuleEnv mod_env thisMod (num+1)
in (mod_env', num)
let components = [what, show wrapperNum, pkg, mod, nameBase]
return $ mkFastString $ zEncodeString $ intercalate ":" components
{-
Note [Generating fresh names for FFI wrappers]
We used to use a unique, rather than nextWrapperNum, to distinguish
between FFI wrapper functions. However, the wrapper names that we
generate are external names. This means that if a call to them ends up
in an unfolding, then we can't alpha-rename them, and thus if the
unique randomly changes from one compile to another then we get a
spurious ABI change (#4012).
The wrapper counter has to be per-module, not global, so that the number we end
up using is not dependent on the modules compiled before the current one.
-}
{-
************************************************************************
* *
\subsection{Errors}
* *
************************************************************************
-}
pprBinders :: [Name] -> SDoc
-- Used in error messages
-- Use quotes for a single one; they look a bit "busy" for several
pprBinders [bndr] = quotes (ppr bndr)
pprBinders bndrs = pprWithCommas ppr bndrs
notFound :: Name -> TcM TyThing
notFound name
= do { lcl_env <- getLclEnv
; let stage = tcl_th_ctxt lcl_env
; case stage of -- See Note [Out of scope might be a staging error]
Splice {}
| isUnboundName name -> failM -- If the name really isn't in scope
-- don't report it again (#11941)
| otherwise -> stageRestrictionError (quotes (ppr name))
_ -> failWithTc $
TcRnUnknownMessage $ mkPlainError noHints $
vcat[text "GHC internal error:" <+> quotes (ppr name) <+>
text "is not in scope during type checking, but it passed the renamer",
text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]
-- Take care: printing the whole gbl env can
-- cause an infinite loop, in the case where we
-- are in the middle of a recursive TyCon/Class group;
-- so let's just not print it! Getting a loop here is
-- very unhelpful, because it hides one compiler bug with another
}
wrongThingErr :: String -> TcTyThing -> Name -> TcM a
-- It's important that this only calls pprTcTyThingCategory, which in
-- turn does not look at the details of the TcTyThing.
-- See Note [Placeholder PatSyn kinds] in GHC.Tc.Gen.Bind
wrongThingErr expected thing name
= let msg = TcRnUnknownMessage $ mkPlainError noHints $
(pprTcTyThingCategory thing <+> quotes (ppr name) <+>
text "used as a" <+> text expected)
in failWithTc msg
{- Note [Out of scope might be a staging error]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
x = 3
data T = MkT $(foo x)
where 'foo' is imported from somewhere.
This is really a staging error, because we can't run code involving 'x'.
But in fact the type checker processes types first, so 'x' won't even be
in the type envt when we look for it in $(foo x). So inside splices we
report something missing from the type env as a staging error.
See #5752 and #5795.
-}
|