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
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
|
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
-}
{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}
module TcHsType (
-- Type signatures
kcHsSigType, tcClassSigType,
tcHsSigType, tcHsSigWcType,
tcHsPartialSigType,
funsSigCtxt, addSigCtxt, pprSigCtxt,
tcHsClsInstType,
tcHsDeriv, tcHsVectInst,
tcHsTypeApp,
UserTypeCtxt(..),
tcImplicitTKBndrs, tcImplicitTKBndrsType, tcExplicitTKBndrs,
-- Type checking type and class decls
kcLookupTcTyCon, kcTyClTyVars, tcTyClTyVars,
tcDataKindSig,
DataKindCheck(..),
-- Kind-checking types
-- No kind generalisation, no checkValidType
tcWildCardBinders,
kcHsTyVarBndrs,
tcHsLiftedType, tcHsOpenType,
tcHsLiftedTypeNC, tcHsOpenTypeNC,
tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType,
tcHsContext, tcLHsPredType, tcInferApps,
solveEqualities, -- useful re-export
typeLevelMode, kindLevelMode,
kindGeneralize, checkExpectedKindX, instantiateTyUntilN,
reportFloatingKvs,
-- Sort-checking kinds
tcLHsKindSig,
-- Pattern type signatures
tcHsPatSigType, tcPatSig, funAppCtxt
) where
#include "HsVersions.h"
import GhcPrelude
import HsSyn
import TcRnMonad
import TcEvidence
import TcEnv
import TcMType
import TcValidity
import TcUnify
import TcIface
import TcSimplify ( solveEqualities )
import TcType
import TcHsSyn( zonkSigType )
import Inst ( tcInstBinders, tcInstBinder )
import Type
import Kind
import RdrName( lookupLocalRdrOcc )
import Var
import VarSet
import TyCon
import ConLike
import DataCon
import Class
import Name
import NameEnv
import NameSet
import VarEnv
import TysWiredIn
import BasicTypes
import SrcLoc
import Constants ( mAX_CTUPLE_SIZE )
import ErrUtils( MsgDoc )
import Unique
import Util
import UniqSupply
import Outputable
import FastString
import PrelNames hiding ( wildCardName )
import qualified GHC.LanguageExtensions as LangExt
import Maybes
import Data.List ( partition, zipWith4, mapAccumR )
import Control.Monad
{-
----------------------------
General notes
----------------------------
Unlike with expressions, type-checking types both does some checking and
desugars at the same time. This is necessary because we often want to perform
equality checks on the types right away, and it would be incredibly painful
to do this on un-desugared types. Luckily, desugared types are close enough
to HsTypes to make the error messages sane.
During type-checking, we perform as little validity checking as possible.
This is because some type-checking is done in a mutually-recursive knot, and
if we look too closely at the tycons, we'll loop. This is why we always must
use mkNakedTyConApp and mkNakedAppTys, etc., which never look at a tycon.
The mkNamed... functions don't uphold Type invariants, but zonkTcTypeToType
will repair this for us. Note that zonkTcType *is* safe within a knot, and
can be done repeatedly with no ill effect: it just squeezes out metavariables.
Generally, after type-checking, you will want to do validity checking, say
with TcValidity.checkValidType.
Validity checking
~~~~~~~~~~~~~~~~~
Some of the validity check could in principle be done by the kind checker,
but not all:
- During desugaring, we normalise by expanding type synonyms. Only
after this step can we check things like type-synonym saturation
e.g. type T k = k Int
type S a = a
Then (T S) is ok, because T is saturated; (T S) expands to (S Int);
and then S is saturated. This is a GHC extension.
- Similarly, also a GHC extension, we look through synonyms before complaining
about the form of a class or instance declaration
- Ambiguity checks involve functional dependencies, and it's easier to wait
until knots have been resolved before poking into them
Also, in a mutually recursive group of types, we can't look at the TyCon until we've
finished building the loop. So to keep things simple, we postpone most validity
checking until step (3).
Knot tying
~~~~~~~~~~
During step (1) we might fault in a TyCon defined in another module, and it might
(via a loop) refer back to a TyCon defined in this module. So when we tie a big
knot around type declarations with ARecThing, so that the fault-in code can get
the TyCon being defined.
%************************************************************************
%* *
Check types AND do validity checking
* *
************************************************************************
-}
funsSigCtxt :: [Located Name] -> UserTypeCtxt
-- Returns FunSigCtxt, with no redundant-context-reporting,
-- form a list of located names
funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False
funsSigCtxt [] = panic "funSigCtxt"
addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a
addSigCtxt ctxt hs_ty thing_inside
= setSrcSpan (getLoc hs_ty) $
addErrCtxt (pprSigCtxt ctxt hs_ty) $
thing_inside
pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc
-- (pprSigCtxt ctxt <extra> <type>)
-- prints In the type signature for 'f':
-- f :: <type>
-- The <extra> is either empty or "the ambiguity check for"
pprSigCtxt ctxt hs_ty
| Just n <- isSigMaybe ctxt
= hang (text "In the type signature:")
2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)
| otherwise
= hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)
2 (ppr hs_ty)
tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
-- This one is used when we have a LHsSigWcType, but in
-- a place where wildards aren't allowed. The renamer has
-- already checked this, so we can simply ignore it.
tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)
kcHsSigType :: [Located Name] -> LHsSigType GhcRn -> TcM ()
kcHsSigType names (HsIB { hsib_body = hs_ty
, hsib_vars = sig_vars })
= addSigCtxt (funsSigCtxt names) hs_ty $
discardResult $
tcImplicitTKBndrsType sig_vars $
tc_lhs_type typeLevelMode hs_ty liftedTypeKind
tcClassSigType :: [Located Name] -> LHsSigType GhcRn -> TcM Type
-- Does not do validity checking; this must be done outside
-- the recursive class declaration "knot"
tcClassSigType names sig_ty
= addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $
tc_hs_sig_type_and_gen sig_ty liftedTypeKind
tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
-- Does validity checking
tcHsSigType ctxt sig_ty
= addSigCtxt ctxt (hsSigType sig_ty) $
do { kind <- case expectedKindInCtxt ctxt of
AnythingKind -> newMetaKindVar
TheKind k -> return k
OpenKind -> newOpenTypeKind
-- The kind is checked by checkValidType, and isn't necessarily
-- of kind * in a Template Haskell quote eg [t| Maybe |]
-- Generalise here: see Note [Kind generalisation]
; do_kind_gen <- decideKindGeneralisationPlan sig_ty
; ty <- if do_kind_gen
then tc_hs_sig_type_and_gen sig_ty kind
else tc_hs_sig_type sig_ty kind >>= zonkTcType
; checkValidType ctxt ty
; return ty }
tc_hs_sig_type_and_gen :: LHsSigType GhcRn -> Kind -> TcM Type
-- Kind-checks/desugars an 'LHsSigType',
-- solve equalities,
-- and then kind-generalizes.
-- This will never emit constraints, as it uses solveEqualities interally.
-- No validity checking, but it does zonk en route to generalization
tc_hs_sig_type_and_gen hs_ty kind
= do { ty <- solveEqualities $
tc_hs_sig_type hs_ty kind
-- NB the call to solveEqualities, which unifies all those
-- kind variables floating about, immediately prior to
-- kind generalisation
; kindGeneralizeType ty }
tc_hs_sig_type :: LHsSigType GhcRn -> Kind -> TcM Type
-- Kind-check/desugar a 'LHsSigType', but does not solve
-- the equalities that arise from doing so; instead it may
-- emit kind-equality constraints into the monad
-- No zonking or validity checking
tc_hs_sig_type (HsIB { hsib_vars = sig_vars
, hsib_body = hs_ty }) kind
= do { (tkvs, ty) <- tcImplicitTKBndrsType sig_vars $
tc_lhs_type typeLevelMode hs_ty kind
; return (mkSpecForAllTys tkvs ty) }
-----------------
tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])
-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause
-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments
-- E.g. class C (a::*) (b::k->k)
-- data T a b = ... deriving( C Int )
-- returns ([k], C, [k, Int], [k->k])
tcHsDeriv hs_ty
= do { cls_kind <- newMetaKindVar
-- always safe to kind-generalize, because there
-- can be no covars in an outer scope
; ty <- checkNoErrs $
-- avoid redundant error report with "illegal deriving", below
tc_hs_sig_type_and_gen hs_ty cls_kind
; cls_kind <- zonkTcType cls_kind
; let (tvs, pred) = splitForAllTys ty
; let (args, _) = splitFunTys cls_kind
; case getClassPredTys_maybe pred of
Just (cls, tys) -> return (tvs, cls, tys, args)
Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }
tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt
-> LHsSigType GhcRn
-> TcM ([TyVar], ThetaType, Class, [Type])
-- Like tcHsSigType, but for a class instance declaration
tcHsClsInstType user_ctxt hs_inst_ty
= setSrcSpan (getLoc (hsSigType hs_inst_ty)) $
do { inst_ty <- tc_hs_sig_type_and_gen hs_inst_ty constraintKind
; checkValidInstance user_ctxt hs_inst_ty inst_ty }
-- Used for 'VECTORISE [SCALAR] instance' declarations
tcHsVectInst :: LHsSigType GhcRn -> TcM (Class, [Type])
tcHsVectInst ty
| let hs_cls_ty = hsSigType ty
, Just (L _ cls_name, tys) <- hsTyGetAppHead_maybe hs_cls_ty
-- Ignoring the binders looks pretty dodgy to me
= do { (cls, cls_kind) <- tcClass cls_name
; (applied_class, _res_kind)
<- tcTyApps typeLevelMode hs_cls_ty (mkClassPred cls []) cls_kind tys
; case tcSplitTyConApp_maybe applied_class of
Just (_tc, args) -> ASSERT( _tc == classTyCon cls )
return (cls, args)
_ -> failWithTc (text "Too many arguments passed to" <+> ppr cls_name) }
| otherwise
= failWithTc $ text "Malformed instance type"
----------------------------------------------
-- | Type-check a visible type application
tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type
tcHsTypeApp wc_ty kind
| HsWC { hswc_wcs = sig_wcs, hswc_body = hs_ty } <- wc_ty
= do { ty <- tcWildCardBindersX newWildTyVar sig_wcs $ \ _ ->
tcCheckLHsType hs_ty kind
; ty <- zonkTcType ty
; checkValidType TypeAppCtxt ty
; return ty }
-- NB: we don't call emitWildcardHoleConstraints here, because
-- we want any holes in visible type applications to be used
-- without fuss. No errors, warnings, extensions, etc.
{-
************************************************************************
* *
The main kind checker: no validity checks here
* *
************************************************************************
First a couple of simple wrappers for kcHsType
-}
---------------------------
tcHsOpenType, tcHsLiftedType,
tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType
-- Used for type signatures
-- Do not do validity checking
tcHsOpenType ty = addTypeCtxt ty $ tcHsOpenTypeNC ty
tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty
tcHsOpenTypeNC ty = do { ek <- newOpenTypeKind
; tc_lhs_type typeLevelMode ty ek }
tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind
-- Like tcHsType, but takes an expected kind
tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM TcType
tcCheckLHsType hs_ty exp_kind
= addTypeCtxt hs_ty $
tc_lhs_type typeLevelMode hs_ty exp_kind
tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind)
-- Called from outside: set the context
tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty)
-- Like tcLHsType, but use it in a context where type synonyms and type families
-- do not need to be saturated, like in a GHCi :kind call
tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)
tcLHsTypeUnsaturated ty = addTypeCtxt ty (tc_infer_lhs_type mode ty)
where
mode = allowUnsaturated typeLevelMode
---------------------------
-- | Should we generalise the kind of this type signature?
-- We *should* generalise if the type is closed
-- or if NoMonoLocalBinds is set. Otherwise, nope.
-- See Note [Kind generalisation plan]
decideKindGeneralisationPlan :: LHsSigType GhcRn -> TcM Bool
decideKindGeneralisationPlan sig_ty@(HsIB { hsib_closed = closed })
= do { mono_locals <- xoptM LangExt.MonoLocalBinds
; let should_gen = not mono_locals || closed
; traceTc "decideKindGeneralisationPlan"
(ppr sig_ty $$ text "should gen?" <+> ppr should_gen)
; return should_gen }
{- Note [Kind generalisation plan]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When should we do kind-generalisation for user-written type signature?
Answer: we use the same rule as for value bindings:
* We always kind-generalise if the type signature is closed
* Additionally, we attempt to generalise if we have NoMonoLocalBinds
Trac #13337 shows the problem if we kind-generalise an open type (i.e.
one that mentions in-scope tpe variable
foo :: forall k (a :: k) proxy. (Typeable k, Typeable a)
=> proxy a -> String
foo _ = case eqT :: Maybe (k :~: Type) of
Nothing -> ...
Just Refl -> case eqT :: Maybe (a :~: Int) of ...
In the expression type sig on the last line, we have (a :: k)
but (Int :: Type). Since (:~:) is kind-homogeneous, this requires
k ~ *, which is true in the Refl branch of the outer case.
That equality will be solved if we allow it to float out to the
implication constraint for the Refl match, bnot not if we aggressively
attempt to solve all equalities the moment they occur; that is, when
checking (Maybe (a :~: Int)). (NB: solveEqualities fails unless it
solves all the kind equalities, which is the right thing at top level.)
So here the right thing is simply not to do kind generalisation!
************************************************************************
* *
Type-checking modes
* *
************************************************************************
The kind-checker is parameterised by a TcTyMode, which contains some
information about where we're checking a type.
The renamer issues errors about what it can. All errors issued here must
concern things that the renamer can't handle.
-}
-- | Info about the context in which we're checking a type. Currently,
-- differentiates only between types and kinds, but this will likely
-- grow, at least to include the distinction between patterns and
-- not-patterns.
data TcTyMode
= TcTyMode { mode_level :: TypeOrKind
, mode_unsat :: Bool -- True <=> allow unsaturated type families
}
-- The mode_unsat field is solely so that type families/synonyms can be unsaturated
-- in GHCi :kind calls
typeLevelMode :: TcTyMode
typeLevelMode = TcTyMode { mode_level = TypeLevel, mode_unsat = False }
kindLevelMode :: TcTyMode
kindLevelMode = TcTyMode { mode_level = KindLevel, mode_unsat = False }
allowUnsaturated :: TcTyMode -> TcTyMode
allowUnsaturated mode = mode { mode_unsat = True }
-- switch to kind level
kindLevel :: TcTyMode -> TcTyMode
kindLevel mode = mode { mode_level = KindLevel }
instance Outputable TcTyMode where
ppr = ppr . mode_level
{-
Note [Bidirectional type checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In expressions, whenever we see a polymorphic identifier, say `id`, we are
free to instantiate it with metavariables, knowing that we can always
re-generalize with type-lambdas when necessary. For example:
rank2 :: (forall a. a -> a) -> ()
x = rank2 id
When checking the body of `x`, we can instantiate `id` with a metavariable.
Then, when we're checking the application of `rank2`, we notice that we really
need a polymorphic `id`, and then re-generalize over the unconstrained
metavariable.
In types, however, we're not so lucky, because *we cannot re-generalize*!
There is no lambda. So, we must be careful only to instantiate at the last
possible moment, when we're sure we're never going to want the lost polymorphism
again. This is done in calls to tcInstBinders.
To implement this behavior, we use bidirectional type checking, where we
explicitly think about whether we know the kind of the type we're checking
or not. Note that there is a difference between not knowing a kind and
knowing a metavariable kind: the metavariables are TauTvs, and cannot become
forall-quantified kinds. Previously (before dependent types), there were
no higher-rank kinds, and so we could instantiate early and be sure that
no types would have polymorphic kinds, and so we could always assume that
the kind of a type was a fresh metavariable. Not so anymore, thus the
need for two algorithms.
For HsType forms that can never be kind-polymorphic, we implement only the
"down" direction, where we safely assume a metavariable kind. For HsType forms
that *can* be kind-polymorphic, we implement just the "up" (functions with
"infer" in their name) version, as we gain nothing by also implementing the
"down" version.
Note [Future-proofing the type checker]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As discussed in Note [Bidirectional type checking], each HsType form is
handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions
are mutually recursive, so that either one can work for any type former.
But, we want to make sure that our pattern-matches are complete. So,
we have a bunch of repetitive code just so that we get warnings if we're
missing any patterns.
-}
------------------------------------------
-- | Check and desugar a type, returning the core type and its
-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression
-- level.
tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)
tc_infer_lhs_type mode (L span ty)
= setSrcSpan span $
do { (ty', kind) <- tc_infer_hs_type mode ty
; return (ty', kind) }
-- | Infer the kind of a type and desugar. This is the "up" type-checker,
-- as described in Note [Bidirectional type checking]
tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)
tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode tv
tc_infer_hs_type mode (HsAppTy ty1 ty2)
= do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty
; fun_kind' <- zonkTcType fun_kind
; tcTyApps mode fun_ty fun_ty' fun_kind' arg_tys }
tc_infer_hs_type mode (HsParTy t) = tc_infer_lhs_type mode t
tc_infer_hs_type mode (HsOpTy lhs (L loc_op op) rhs)
| not (op `hasKey` funTyConKey)
= do { (op', op_kind) <- tcTyVar mode op
; op_kind' <- zonkTcType op_kind
; tcTyApps mode (noLoc $ HsTyVar NotPromoted (L loc_op op)) op' op_kind' [lhs, rhs] }
tc_infer_hs_type mode (HsKindSig ty sig)
= do { sig' <- tc_lhs_kind (kindLevel mode) sig
; ty' <- tc_lhs_type mode ty sig'
; return (ty', sig') }
-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType' to communicate
-- the splice location to the typechecker. Here we skip over it in order to have
-- the same kind inferred for a given expression whether it was produced from
-- splices or not.
--
-- See Note [Delaying modFinalizers in untyped splices].
tc_infer_hs_type mode (HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _)
= tc_infer_hs_type mode ty
tc_infer_hs_type mode (HsDocTy ty _) = tc_infer_lhs_type mode ty
tc_infer_hs_type _ (HsCoreTy ty) = return (ty, typeKind ty)
tc_infer_hs_type mode other_ty
= do { kv <- newMetaKindVar
; ty' <- tc_hs_type mode other_ty kv
; return (ty', kv) }
------------------------------------------
tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType
tc_lhs_type mode (L span ty) exp_kind
= setSrcSpan span $
do { ty' <- tc_hs_type mode ty exp_kind
; return ty' }
------------------------------------------
tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind
-> TcM TcType
tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of
TypeLevel ->
do { arg_k <- newOpenTypeKind
; res_k <- newOpenTypeKind
; ty1' <- tc_lhs_type mode ty1 arg_k
; ty2' <- tc_lhs_type mode ty2 res_k
; checkExpectedKind (HsFunTy ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind }
KindLevel -> -- no representation polymorphism in kinds. yet.
do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind
; ty2' <- tc_lhs_type mode ty2 liftedTypeKind
; checkExpectedKind (HsFunTy ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind }
------------------------------------------
-- See also Note [Bidirectional type checking]
tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
tc_hs_type mode (HsParTy ty) exp_kind = tc_lhs_type mode ty exp_kind
tc_hs_type mode (HsDocTy ty _) exp_kind = tc_lhs_type mode ty exp_kind
tc_hs_type _ ty@(HsBangTy {}) _
-- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
-- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
-- bangs are invalid, so fail. (#7210)
= failWithTc (text "Unexpected strictness annotation:" <+> ppr ty)
tc_hs_type _ ty@(HsRecTy _) _
-- Record types (which only show up temporarily in constructor
-- signatures) should have been removed by now
= failWithTc (text "Record syntax is illegal here:" <+> ppr ty)
-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'.
-- Here we get rid of it and add the finalizers to the global environment
-- while capturing the local environment.
--
-- See Note [Delaying modFinalizers in untyped splices].
tc_hs_type mode (HsSpliceTy (HsSpliced mod_finalizers (HsSplicedTy ty))
_
)
exp_kind
= do addModFinalizersWithLclEnv mod_finalizers
tc_hs_type mode ty exp_kind
-- This should never happen; type splices are expanded by the renamer
tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind
= failWithTc (text "Unexpected type splice:" <+> ppr ty)
---------- Functions and applications
tc_hs_type mode (HsFunTy ty1 ty2) exp_kind
= tc_fun_type mode ty1 ty2 exp_kind
tc_hs_type mode (HsOpTy ty1 (L _ op) ty2) exp_kind
| op `hasKey` funTyConKey
= tc_fun_type mode ty1 ty2 exp_kind
--------- Foralls
tc_hs_type mode (HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind
= fmap fst $
tcExplicitTKBndrs hs_tvs $ \ tvs' ->
-- Do not kind-generalise here! See Note [Kind generalisation]
-- Why exp_kind? See Note [Body kind of HsForAllTy]
do { ty' <- tc_lhs_type mode ty exp_kind
; let bound_vars = allBoundVariables ty'
bndrs = mkTyVarBinders Specified tvs'
; return (mkForAllTys bndrs ty', bound_vars) }
tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind
| null (unLoc ctxt)
= tc_lhs_type mode ty exp_kind
| otherwise
= do { ctxt' <- tc_hs_context mode ctxt
-- See Note [Body kind of a HsQualTy]
; ty' <- if isConstraintKind exp_kind
then tc_lhs_type mode ty constraintKind
else do { ek <- newOpenTypeKind
-- The body kind (result of the function)
-- can be * or #, hence newOpenTypeKind
; ty' <- tc_lhs_type mode ty ek
; checkExpectedKind (unLoc ty) ty' liftedTypeKind exp_kind }
; return (mkPhiTy ctxt' ty') }
--------- Lists, arrays, and tuples
tc_hs_type mode rn_ty@(HsListTy elt_ty) exp_kind
= do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
; checkWiredInTyCon listTyCon
; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }
tc_hs_type mode rn_ty@(HsPArrTy elt_ty) exp_kind
= do { MASSERT( isTypeLevel (mode_level mode) )
; tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
; checkWiredInTyCon parrTyCon
; checkExpectedKind rn_ty (mkPArrTy tau_ty) liftedTypeKind exp_kind }
-- See Note [Distinguishing tuple kinds] in HsTypes
-- See Note [Inferring tuple kinds]
tc_hs_type mode rn_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind
-- (NB: not zonking before looking at exp_k, to avoid left-right bias)
| Just tup_sort <- tupKindSort_maybe exp_kind
= traceTc "tc_hs_type tuple" (ppr hs_tys) >>
tc_tuple rn_ty mode tup_sort hs_tys exp_kind
| otherwise
= do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)
; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys
; kinds <- mapM zonkTcType kinds
-- Infer each arg type separately, because errors can be
-- confusing if we give them a shared kind. Eg Trac #7410
-- (Either Int, Int), we do not want to get an error saying
-- "the second argument of a tuple should have kind *->*"
; let (arg_kind, tup_sort)
= case [ (k,s) | k <- kinds
, Just s <- [tupKindSort_maybe k] ] of
((k,s) : _) -> (k,s)
[] -> (liftedTypeKind, BoxedTuple)
-- In the [] case, it's not clear what the kind is, so guess *
; tys' <- sequence [ setSrcSpan loc $
checkExpectedKind hs_ty ty kind arg_kind
| ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]
; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }
tc_hs_type mode rn_ty@(HsTupleTy hs_tup_sort tys) exp_kind
= tc_tuple rn_ty mode tup_sort tys exp_kind
where
tup_sort = case hs_tup_sort of -- Fourth case dealt with above
HsUnboxedTuple -> UnboxedTuple
HsBoxedTuple -> BoxedTuple
HsConstraintTuple -> ConstraintTuple
_ -> panic "tc_hs_type HsTupleTy"
tc_hs_type mode rn_ty@(HsSumTy hs_tys) exp_kind
= do { let arity = length hs_tys
; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys
; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds
; let arg_reps = map getRuntimeRepFromKind arg_kinds
arg_tys = arg_reps ++ tau_tys
; checkExpectedKind rn_ty
(mkTyConApp (sumTyCon arity) arg_tys)
(unboxedSumKind arg_reps)
exp_kind
}
--------- Promoted lists and tuples
tc_hs_type mode rn_ty@(HsExplicitListTy _ _k tys) exp_kind
= do { tks <- mapM (tc_infer_lhs_type mode) tys
; (taus', kind) <- unifyKinds tys tks
; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')
; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }
where
mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]
mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k]
tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind
-- using newMetaKindVar means that we force instantiations of any polykinded
-- types. At first, I just used tc_infer_lhs_type, but that led to #11255.
= do { ks <- replicateM arity newMetaKindVar
; taus <- zipWithM (tc_lhs_type mode) tys ks
; let kind_con = tupleTyCon Boxed arity
ty_con = promotedTupleDataCon Boxed arity
tup_k = mkTyConApp kind_con ks
; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }
where
arity = length tys
--------- Constraint types
tc_hs_type mode rn_ty@(HsIParamTy (L _ n) ty) exp_kind
= do { MASSERT( isTypeLevel (mode_level mode) )
; ty' <- tc_lhs_type mode ty liftedTypeKind
; let n' = mkStrLitTy $ hsIPNameFS n
; ipClass <- tcLookupClass ipClassName
; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])
constraintKind exp_kind }
tc_hs_type mode rn_ty@(HsEqTy ty1 ty2) exp_kind
= do { (ty1', kind1) <- tc_infer_lhs_type mode ty1
; (ty2', kind2) <- tc_infer_lhs_type mode ty2
; ty2'' <- checkExpectedKind (unLoc ty2) ty2' kind2 kind1
; eq_tc <- tcLookupTyCon eqTyConName
; let ty' = mkNakedTyConApp eq_tc [kind1, ty1', ty2'']
; checkExpectedKind rn_ty ty' constraintKind exp_kind }
--------- Literals
tc_hs_type _ rn_ty@(HsTyLit (HsNumTy _ n)) exp_kind
= do { checkWiredInTyCon typeNatKindCon
; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind }
tc_hs_type _ rn_ty@(HsTyLit (HsStrTy _ s)) exp_kind
= do { checkWiredInTyCon typeSymbolKindCon
; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }
--------- Potentially kind-polymorphic types: call the "up" checker
-- See Note [Future-proofing the type checker]
tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek
tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek
tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek
tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek
tc_hs_type mode ty@(HsCoreTy {}) ek = tc_infer_hs_type_ek mode ty ek
tc_hs_type _ (HsWildCardTy wc) exp_kind
= do { wc_tv <- tcWildCardOcc wc exp_kind
; return (mkTyVarTy wc_tv) }
-- disposed of by renamer
tc_hs_type _ ty@(HsAppsTy {}) _
= pprPanic "tc_hs_tyep HsAppsTy" (ppr ty)
tcWildCardOcc :: HsWildCardInfo GhcRn -> Kind -> TcM TcTyVar
tcWildCardOcc wc_info exp_kind
= do { wc_tv <- tcLookupTyVar (wildCardName wc_info)
-- The wildcard's kind should be an un-filled-in meta tyvar
; let Just wc_kind_var = tcGetTyVar_maybe (tyVarKind wc_tv)
; writeMetaTyVar wc_kind_var exp_kind
; return wc_tv }
---------------------------
-- | Call 'tc_infer_hs_type' and check its result against an expected kind.
tc_infer_hs_type_ek :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
tc_infer_hs_type_ek mode hs_ty ek
= do { (ty, k) <- tc_infer_hs_type mode hs_ty
; checkExpectedKind hs_ty ty k ek }
---------------------------
tupKindSort_maybe :: TcKind -> Maybe TupleSort
tupKindSort_maybe k
| Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'
| Just k' <- tcView k = tupKindSort_maybe k'
| isConstraintKind k = Just ConstraintTuple
| isLiftedTypeKind k = Just BoxedTuple
| otherwise = Nothing
tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType
tc_tuple rn_ty mode tup_sort tys exp_kind
= do { arg_kinds <- case tup_sort of
BoxedTuple -> return (nOfThem arity liftedTypeKind)
UnboxedTuple -> mapM (\_ -> newOpenTypeKind) tys
ConstraintTuple -> return (nOfThem arity constraintKind)
; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds
; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }
where
arity = length tys
finish_tuple :: HsType GhcRn
-> TupleSort
-> [TcType] -- ^ argument types
-> [TcKind] -- ^ of these kinds
-> TcKind -- ^ expected kind of the whole tuple
-> TcM TcType
finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind
= do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind)
; let arg_tys = case tup_sort of
-- See also Note [Unboxed tuple RuntimeRep vars] in TyCon
UnboxedTuple -> tau_reps ++ tau_tys
BoxedTuple -> tau_tys
ConstraintTuple -> tau_tys
; tycon <- case tup_sort of
ConstraintTuple
| arity > mAX_CTUPLE_SIZE
-> failWith (bigConstraintTuple arity)
| otherwise -> tcLookupTyCon (cTupleTyConName arity)
BoxedTuple -> do { let tc = tupleTyCon Boxed arity
; checkWiredInTyCon tc
; return tc }
UnboxedTuple -> return (tupleTyCon Unboxed arity)
; checkExpectedKind rn_ty (mkTyConApp tycon arg_tys) res_kind exp_kind }
where
arity = length tau_tys
tau_reps = map getRuntimeRepFromKind tau_kinds
res_kind = case tup_sort of
UnboxedTuple -> unboxedTupleKind tau_reps
BoxedTuple -> liftedTypeKind
ConstraintTuple -> constraintKind
bigConstraintTuple :: Arity -> MsgDoc
bigConstraintTuple arity
= hang (text "Constraint tuple arity too large:" <+> int arity
<+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))
2 (text "Instead, use a nested tuple")
---------------------------
-- | Apply a type of a given kind to a list of arguments. This instantiates
-- invisible parameters as necessary. Always consumes all the arguments,
-- using matchExpectedFunKind as necessary.
-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.
-- These kinds should be used to instantiate invisible kind variables;
-- they come from an enclosing class for an associated type/data family.
tcInferApps :: TcTyMode
-> Maybe (VarEnv Kind) -- ^ Possibly, kind info (see above)
-> LHsType GhcRn -- ^ Function (for printing only)
-> TcType -- ^ Function (could be knot-tied)
-> TcKind -- ^ Function kind (zonked)
-> [LHsType GhcRn] -- ^ Args
-> TcM (TcType, [TcType], TcKind) -- ^ (f args, args, result kind)
tcInferApps mode mb_kind_info orig_hs_ty fun_ty fun_ki orig_hs_args
= do { traceTc "tcInferApps" (ppr orig_hs_ty $$ ppr orig_hs_args $$ ppr fun_ki)
; go 1 [] empty_subst fun_ty orig_ki_binders orig_inner_ki orig_hs_args }
where
empty_subst = mkEmptyTCvSubst $ mkInScopeSet $
tyCoVarsOfType fun_ki
(orig_ki_binders, orig_inner_ki) = tcSplitPiTys fun_ki
go :: Int -- the # of the next argument
-> [TcType] -- already type-checked args, in reverse order
-> TCvSubst -- instantiating substitution
-> TcType -- function applied to some args, could be knot-tied
-> [TyBinder] -- binders in function kind (both vis. and invis.)
-> TcKind -- function kind body (not a Pi-type)
-> [LHsType GhcRn] -- un-type-checked args
-> TcM (TcType, [TcType], TcKind) -- same as overall return type
-- no user-written args left. We're done!
go _ acc_args subst fun ki_binders inner_ki []
= return (fun, reverse acc_args, substTy subst $ mkPiTys ki_binders inner_ki)
-- The function's kind has a binder. Is it visible or invisible?
go n acc_args subst fun (ki_binder:ki_binders) inner_ki
all_args@(arg:args)
| isInvisibleBinder ki_binder
-- It's invisible. Instantiate.
= do { traceTc "tcInferApps (invis)" (ppr ki_binder $$ ppr subst)
; (subst', arg') <- tcInstBinder mb_kind_info subst ki_binder
; go n (arg' : acc_args) subst' (mkNakedAppTy fun arg')
ki_binders inner_ki all_args }
| otherwise
-- It's visible. Check the next user-written argument
= do { traceTc "tcInferApps (vis)" (vcat [ ppr ki_binder, ppr arg
, ppr (tyBinderType ki_binder)
, ppr subst ])
; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $
tc_lhs_type mode arg (substTy subst $ tyBinderType ki_binder)
; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg'
; go (n+1) (arg' : acc_args) subst' (mkNakedAppTy fun arg')
ki_binders inner_ki args }
-- We've run out of known binders in the functions's kind.
go n acc_args subst fun [] inner_ki all_args
| not (null new_ki_binders)
-- But, after substituting, we have more binders.
= go n acc_args zapped_subst fun new_ki_binders new_inner_ki all_args
| otherwise
-- Even after substituting, still no binders. Use matchExpectedFunKind
= do { traceTc "tcInferApps (no binder)" (ppr new_inner_ki $$ ppr zapped_subst)
; (co, arg_k, res_k)
<- matchExpectedFunKind (mkHsAppTys orig_hs_ty (take (n-1) orig_hs_args))
substed_inner_ki
; let subst' = zapped_subst `extendTCvInScopeSet` tyCoVarsOfTypes [arg_k, res_k]
; go n acc_args subst' (fun `mkNakedCastTy` co)
[mkAnonBinder arg_k] res_k all_args }
where
substed_inner_ki = substTy subst inner_ki
(new_ki_binders, new_inner_ki) = tcSplitPiTys substed_inner_ki
zapped_subst = zapTCvSubst subst
-- | Applies a type to a list of arguments.
-- Always consumes all the arguments, using 'matchExpectedFunKind' as
-- necessary. If you wish to apply a type to a list of HsTypes, this is
-- your function.
-- Used for type-checking types only.
tcTyApps :: TcTyMode
-> LHsType GhcRn -- ^ Function (for printing only)
-> TcType -- ^ Function (could be knot-tied)
-> TcKind -- ^ Function kind (zonked)
-> [LHsType GhcRn] -- ^ Args
-> TcM (TcType, TcKind) -- ^ (f args, result kind)
tcTyApps mode orig_hs_ty ty ki args
= do { (ty', _args, ki') <- tcInferApps mode Nothing orig_hs_ty ty ki args
; return (ty', ki') }
--------------------------
-- like checkExpectedKindX, but returns only the final type; convenient wrapper
checkExpectedKind :: HsType GhcRn
-> TcType
-> TcKind
-> TcKind
-> TcM TcType
checkExpectedKind hs_ty ty act exp
= fstOf3 <$> checkExpectedKindX Nothing (ppr hs_ty) ty act exp
checkExpectedKindX :: Maybe (VarEnv Kind) -- Possibly, instantiations for kind vars
-> SDoc -- HsType whose kind we're checking
-> TcType -- the type whose kind we're checking
-> TcKind -- the known kind of that type, k
-> TcKind -- the expected kind, exp_kind
-> TcM (TcType, [TcType], TcCoercionN)
-- (an possibly-inst'ed, casted type :: exp_kind, the new args, the coercion)
-- Instantiate a kind (if necessary) and then call unifyType
-- (checkExpectedKind ty act_kind exp_kind)
-- checks that the actual kind act_kind is compatible
-- with the expected kind exp_kind
checkExpectedKindX mb_kind_env pp_hs_ty ty act_kind exp_kind
= do { (ty', new_args, act_kind') <- instantiate ty act_kind exp_kind
; let origin = TypeEqOrigin { uo_actual = act_kind'
, uo_expected = exp_kind
, uo_thing = Just pp_hs_ty
, uo_visible = True } -- the hs_ty is visible
; co_k <- uType KindLevel origin act_kind' exp_kind
; traceTc "checkExpectedKind" (vcat [ ppr act_kind
, ppr exp_kind
, ppr co_k ])
; let result_ty = ty' `mkNakedCastTy` co_k
; return (result_ty, new_args, co_k) }
where
-- we need to make sure that both kinds have the same number of implicit
-- foralls out front. If the actual kind has more, instantiate accordingly.
-- Otherwise, just pass the type & kind through -- the errors are caught
-- in unifyType.
instantiate :: TcType -- the type
-> TcKind -- of this kind
-> TcKind -- but expected to be of this one
-> TcM ( TcType -- the inst'ed type
, [TcType] -- the new args
, TcKind ) -- its new kind
instantiate ty act_ki exp_ki
= let (exp_bndrs, _) = splitPiTysInvisible exp_ki in
instantiateTyUntilN mb_kind_env (length exp_bndrs) ty act_ki
-- | Instantiate @n@ invisible arguments to a type. If @n <= 0@, no instantiation
-- occurs. If @n@ is too big, then all available invisible arguments are instantiated.
-- (In other words, this function is very forgiving about bad values of @n@.)
instantiateTyN :: Maybe (VarEnv Kind) -- ^ Predetermined instantiations
-- (for assoc. type patterns)
-> Int -- ^ @n@
-> TcType -- ^ the type
-> [TyBinder] -> TcKind -- ^ its kind
-> TcM (TcType, [TcType], TcKind) -- ^ The inst'ed type, new args, kind
instantiateTyN mb_kind_env n ty bndrs inner_ki
= let -- NB: splitAt is forgiving with invalid numbers
(inst_bndrs, leftover_bndrs) = splitAt n bndrs
ki = mkPiTys bndrs inner_ki
empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ki))
in
if n <= 0 then return (ty, [], ki) else
do { (subst, inst_args) <- tcInstBinders empty_subst mb_kind_env inst_bndrs
; let rebuilt_ki = mkPiTys leftover_bndrs inner_ki
ki' = substTy subst rebuilt_ki
; traceTc "instantiateTyN" (vcat [ ppr ki
, ppr n
, ppr subst
, ppr rebuilt_ki
, ppr ki' ])
; return (mkNakedAppTys ty inst_args, inst_args, ki') }
-- | Instantiate a type to have at most @n@ invisible arguments.
instantiateTyUntilN :: Maybe (VarEnv Kind) -- ^ Possibly, instantiations for vars
-> Int -- ^ @n@
-> TcType -- ^ the type
-> TcKind -- ^ its kind
-> TcM (TcType, [TcType], TcKind) -- ^ The inst'ed type, new args,
-- final kind
instantiateTyUntilN mb_kind_env n ty ki
= let (bndrs, inner_ki) = splitPiTysInvisible ki
num_to_inst = length bndrs - n
in
instantiateTyN mb_kind_env num_to_inst ty bndrs inner_ki
---------------------------
tcHsContext :: LHsContext GhcRn -> TcM [PredType]
tcHsContext = tc_hs_context typeLevelMode
tcLHsPredType :: LHsType GhcRn -> TcM PredType
tcLHsPredType = tc_lhs_pred typeLevelMode
tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]
tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)
tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType
tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind
---------------------------
tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)
-- See Note [Type checking recursive type and class declarations]
-- in TcTyClsDecls
tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon
= do { traceTc "lk1" (ppr name)
; thing <- tcLookup name
; case thing of
ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)
ATcTyCon tc_tc -> do { -- See Note [GADT kind self-reference]
unless
(isTypeLevel (mode_level mode))
(promotionErr name TyConPE)
; check_tc tc_tc
; tc <- get_loopy_tc name tc_tc
; handle_tyfams tc tc_tc }
-- mkNakedTyConApp: see Note [Type-checking inside the knot]
-- NB: we really should check if we're at the kind level
-- and if the tycon is promotable if -XNoTypeInType is set.
-- But this is a terribly large amount of work! Not worth it.
AGlobal (ATyCon tc)
-> do { check_tc tc
; handle_tyfams tc tc }
AGlobal (AConLike (RealDataCon dc))
-> do { data_kinds <- xoptM LangExt.DataKinds
; unless (data_kinds || specialPromotedDc dc) $
promotionErr name NoDataKindsDC
; type_in_type <- xoptM LangExt.TypeInType
; unless ( type_in_type ||
( isTypeLevel (mode_level mode) &&
isLegacyPromotableDataCon dc ) ||
( isKindLevel (mode_level mode) &&
specialPromotedDc dc ) ) $
promotionErr name NoTypeInTypeDC
; let tc = promoteDataCon dc
; return (mkNakedTyConApp tc [], tyConKind tc) }
APromotionErr err -> promotionErr name err
_ -> wrongThingErr "type" thing name }
where
check_tc :: TyCon -> TcM ()
check_tc tc = do { type_in_type <- xoptM LangExt.TypeInType
; data_kinds <- xoptM LangExt.DataKinds
; unless (isTypeLevel (mode_level mode) ||
data_kinds ||
isKindTyCon tc) $
promotionErr name NoDataKindsTC
; unless (isTypeLevel (mode_level mode) ||
type_in_type ||
isLegacyPromotableTyCon tc) $
promotionErr name NoTypeInTypeTC }
-- if we are type-checking a type family tycon, we must instantiate
-- any invisible arguments right away. Otherwise, we get #11246
handle_tyfams :: TyCon -- the tycon to instantiate (might be loopy)
-> TcTyCon -- a non-loopy version of the tycon
-> TcM (TcType, TcKind)
handle_tyfams tc tc_tc
| mightBeUnsaturatedTyCon tc_tc || mode_unsat mode
-- This is where mode_unsat is used
= do { traceTc "tcTyVar2a" (ppr tc_tc $$ ppr tc_kind)
; return (ty, tc_kind) }
| otherwise
= do { (tc_ty, _, kind) <- instantiateTyN Nothing (length (tyConBinders tc_tc))
ty tc_kind_bndrs tc_inner_ki
-- tc and tc_ty must not be traced here, because that would
-- force the evaluation of a potentially knot-tied variable (tc),
-- and the typechecker would hang, as per #11708
; traceTc "tcTyVar2b" (vcat [ ppr tc_tc <+> dcolon <+> ppr tc_kind
, ppr kind ])
; return (tc_ty, kind) }
where
ty = mkNakedTyConApp tc []
tc_kind = tyConKind tc_tc
(tc_kind_bndrs, tc_inner_ki) = splitPiTysInvisible tc_kind
get_loopy_tc :: Name -> TyCon -> TcM TyCon
-- Return the knot-tied global TyCon if there is one
-- Otherwise the local TcTyCon; we must be doing kind checking
-- but we still want to return a TyCon of some sort to use in
-- error messages
get_loopy_tc name tc_tc
= do { env <- getGblEnv
; case lookupNameEnv (tcg_type_env env) name of
Just (ATyCon tc) -> return tc
_ -> do { traceTc "lk1 (loopy)" (ppr name)
; return tc_tc } }
tcClass :: Name -> TcM (Class, TcKind)
tcClass cls -- Must be a class
= do { thing <- tcLookup cls
; case thing of
ATcTyCon tc -> return (aThingErr "tcClass" cls, tyConKind tc)
AGlobal (ATyCon tc)
| Just cls <- tyConClass_maybe tc
-> return (cls, tyConKind tc)
_ -> wrongThingErr "class" thing cls }
aThingErr :: String -> Name -> b
-- The type checker for types is sometimes called simply to
-- do *kind* checking; and in that case it ignores the type
-- returned. Which is a good thing since it may not be available yet!
aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x)
{-
Note [Type-checking inside the knot]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we are checking the argument types of a data constructor. We
must zonk the types before making the DataCon, because once built we
can't change it. So we must traverse the type.
BUT the parent TyCon is knot-tied, so we can't look at it yet.
So we must be careful not to use "smart constructors" for types that
look at the TyCon or Class involved.
* Hence the use of mkNakedXXX functions. These do *not* enforce
the invariants (for example that we use (FunTy s t) rather
than (TyConApp (->) [s,t])).
* The zonking functions establish invariants (even zonkTcType, a change from
previous behaviour). So we must never inspect the result of a
zonk that might mention a knot-tied TyCon. This is generally OK
because we zonk *kinds* while kind-checking types. And the TyCons
in kinds shouldn't be knot-tied, because they come from a previous
mutually recursive group.
* TcHsSyn.zonkTcTypeToType also can safely check/establish
invariants.
This is horribly delicate. I hate it. A good example of how
delicate it is can be seen in Trac #7903.
Note [GADT kind self-reference]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A promoted type cannot be used in the body of that type's declaration.
Trac #11554 shows this example, which made GHC loop:
import Data.Kind
data P (x :: k) = Q
data A :: Type where
B :: forall (a :: A). P a -> A
In order to check the constructor B, we need to have the promoted type A, but in
order to get that promoted type, B must first be checked. To prevent looping, a
TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode.
Any ATcTyCon is a TyCon being defined in the current recursive group (see data
type decl for TcTyThing), and all such TyCons are illegal in kinds.
Trac #11962 proposes checking the head of a data declaration separately from
its constructors. This would allow the example above to pass.
Note [Body kind of a HsForAllTy]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The body of a forall is usually a type, but in principle
there's no reason to prohibit *unlifted* types.
In fact, GHC can itself construct a function with an
unboxed tuple inside a for-all (via CPR analysis; see
typecheck/should_compile/tc170).
Moreover in instance heads we get forall-types with
kind Constraint.
It's tempting to check that the body kind is either * or #. But this is
wrong. For example:
class C a b
newtype N = Mk Foo deriving (C a)
We're doing newtype-deriving for C. But notice how `a` isn't in scope in
the predicate `C a`. So we quantify, yielding `forall a. C a` even though
`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but
convenient. Bottom line: don't check for * or # here.
Note [Body kind of a HsQualTy]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If ctxt is non-empty, the HsQualTy really is a /function/, so the
kind of the result really is '*', and in that case the kind of the
body-type can be lifted or unlifted.
However, consider
instance Eq a => Eq [a] where ...
or
f :: (Eq a => Eq [a]) => blah
Here both body-kind of the HsQualTy is Constraint rather than *.
Rather crudely we tell the difference by looking at exp_kind. It's
very convenient to typecheck instance types like any other HsSigType.
Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's
better to reject in checkValidType. If we say that the body kind
should be '*' we risk getting TWO error messages, one saying that Eq
[a] doens't have kind '*', and one saying that we need a Constraint to
the left of the outer (=>).
How do we figure out the right body kind? Well, it's a bit of a
kludge: I just look at the expected kind. If it's Constraint, we
must be in this instance situation context. It's a kludge because it
wouldn't work if any unification was involved to compute that result
kind -- but it isn't. (The true way might be to use the 'mode'
parameter, but that seemed like a sledgehammer to crack a nut.)
Note [Inferring tuple kinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,
we try to figure out whether it's a tuple of kind * or Constraint.
Step 1: look at the expected kind
Step 2: infer argument kinds
If after Step 2 it's not clear from the arguments that it's
Constraint, then it must be *. Once having decided that we re-check
the Check the arguments again to give good error messages
in eg. `(Maybe, Maybe)`
Note that we will still fail to infer the correct kind in this case:
type T a = ((a,a), D a)
type family D :: Constraint -> Constraint
While kind checking T, we do not yet know the kind of D, so we will default the
kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.
Note [Desugaring types]
~~~~~~~~~~~~~~~~~~~~~~~
The type desugarer is phase 2 of dealing with HsTypes. Specifically:
* It transforms from HsType to Type
* It zonks any kinds. The returned type should have no mutable kind
or type variables (hence returning Type not TcType):
- any unconstrained kind variables are defaulted to (Any *) just
as in TcHsSyn.
- there are no mutable type variables because we are
kind-checking a type
Reason: the returned type may be put in a TyCon or DataCon where
it will never subsequently be zonked.
You might worry about nested scopes:
..a:kappa in scope..
let f :: forall b. T '[a,b] -> Int
In this case, f's type could have a mutable kind variable kappa in it;
and we might then default it to (Any *) when dealing with f's type
signature. But we don't expect this to happen because we can't get a
lexically scoped type variable with a mutable kind variable in it. A
delicate point, this. If it becomes an issue we might need to
distinguish top-level from nested uses.
Moreover
* it cannot fail,
* it does no unifications
* it does no validity checking, except for structural matters, such as
(a) spurious ! annotations.
(b) a class used as a type
Note [Kind of a type splice]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider these terms, each with TH type splice inside:
[| e1 :: Maybe $(..blah..) |]
[| e2 :: $(..blah..) |]
When kind-checking the type signature, we'll kind-check the splice
$(..blah..); we want to give it a kind that can fit in any context,
as if $(..blah..) :: forall k. k.
In the e1 example, the context of the splice fixes kappa to *. But
in the e2 example, we'll desugar the type, zonking the kind unification
variables as we go. When we encounter the unconstrained kappa, we
want to default it to '*', not to (Any *).
Help functions for type applications
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-}
addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a
-- Wrap a context around only if we want to show that contexts.
-- Omit invisible ones and ones user's won't grok
addTypeCtxt (L _ ty) thing
= addErrCtxt doc thing
where
doc = text "In the type" <+> quotes (ppr ty)
{-
************************************************************************
* *
Type-variable binders
%* *
%************************************************************************
Note [Scope-check inferred kinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data SameKind :: k -> k -> *
foo :: forall a (b :: Proxy a) (c :: Proxy d). SameKind b c
d has no binding site. So it gets bound implicitly, at the top. The
problem is that d's kind mentions `a`. So it's all ill-scoped.
The way we check for this is to gather all variables *bound* in a
type variable's scope. The type variable's kind should not mention
any of these variables. That is, d's kind can't mention a, b, or c.
We can't just check to make sure that d's kind is in scope, because
we might be about to kindGeneralize.
A little messy, but it works.
Note [Dependent LHsQTyVars]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We track (in the renamer) which explicitly bound variables in a
LHsQTyVars are manifestly dependent; only precisely these variables
may be used within the LHsQTyVars. We must do this so that kcHsTyVarBndrs
can produce the right TyConBinders, and tell Anon vs. Required.
Example data T k1 (a:k1) (b:k2) c
= MkT (Proxy a) (Proxy b) (Proxy c)
Here
(a:k1),(b:k2),(c:k3)
are Anon (explicitly specified as a binder, not used
in the kind of any other binder
k1 is Required (explicitly specifed as a binder, but used
in the kind of another binder i.e. dependently)
k2 is Specified (not explicitly bound, but used in the kind
of another binder)
k3 in Inferred (not lexically in scope at all, but inferred
by kind inference)
and
T :: forall {k3} k1. forall k3 -> k1 -> k2 -> k3 -> *
See Note [TyVarBndrs, TyVarBinders, TyConBinders, and visibility]
in TyCoRep.
kcHsTyVarBndrs uses the hsq_dependent field to decide whether
k1, a, b, c should be Required or Anon.
Earlier, thought it would work simply to do a free-variable check
during kcHsTyVarBndrs, but this is bogus, because there may be
unsolved equalities about. And we don't want to eagerly solve the
equalities, because we may get further information after
kcHsTyVarBndrs is called. (Recall that kcHsTyVarBndrs is usually
called from getInitialKind. The only other case is in kcConDecl.)
This is what implements the rule that all variables intended to be
dependent must be manifestly so.
Sidenote: It's quite possible that later, we'll consider (t -> s)
as a degenerate case of some (pi (x :: t) -> s) and then this will
all get more permissive.
-}
tcWildCardBinders :: [Name]
-> ([(Name, TcTyVar)] -> TcM a)
-> TcM a
tcWildCardBinders = tcWildCardBindersX new_tv
where
new_tv name = do { kind <- newMetaKindVar
; newSkolemTyVar name kind }
tcWildCardBindersX :: (Name -> TcM TcTyVar)
-> [Name]
-> ([(Name, TcTyVar)] -> TcM a)
-> TcM a
tcWildCardBindersX new_wc wc_names thing_inside
= do { wcs <- mapM new_wc wc_names
; let wc_prs = wc_names `zip` wcs
; tcExtendTyVarEnv2 wc_prs $
thing_inside wc_prs }
-- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete,
-- user-supplied kind signature (CUSK), generalise the result.
-- Used in 'getInitialKind' (for tycon kinds and other kinds)
-- and in kind-checking (but not for tycon kinds, which are checked with
-- tcTyClDecls). See also Note [Complete user-supplied kind signatures] in
-- HsDecls.
--
-- This function does not do telescope checking.
kcHsTyVarBndrs :: Name -- ^ of the thing being checked
-> TyConFlavour -- ^ What sort of 'TyCon' is being checked
-> Bool -- ^ True <=> the decl being checked has a CUSK
-> Bool -- ^ True <=> all the hsq_implicit are *kind* vars
-- (will give these kind * if -XNoTypeInType)
-> LHsQTyVars GhcRn
-> TcM (Kind, r) -- ^ The result kind, possibly with other info
-> TcM (TcTyCon, r) -- ^ A suitably-kinded TcTyCon
kcHsTyVarBndrs name flav cusk all_kind_vars
(HsQTvs { hsq_implicit = kv_ns, hsq_explicit = hs_tvs
, hsq_dependent = dep_names }) thing_inside
| cusk
= do { kv_kinds <- mk_kv_kinds
; lvl <- getTcLevel
; let scoped_kvs = zipWith (mk_skolem_tv lvl) kv_ns kv_kinds
; tcExtendTyVarEnv2 (kv_ns `zip` scoped_kvs) $
do { (tc_binders, res_kind, stuff) <- solveEqualities $
bind_telescope hs_tvs thing_inside
-- Now, because we're in a CUSK, quantify over the mentioned
-- kind vars, in dependency order.
; tc_binders <- mapM zonkTcTyVarBinder tc_binders
; res_kind <- zonkTcType res_kind
; let tc_tvs = binderVars tc_binders
qkvs = tyCoVarsOfTypeWellScoped (mkTyConKind tc_binders res_kind)
-- the visibility of tvs doesn't matter here; we just
-- want the free variables not to include the tvs
-- If there are any meta-tvs left, the user has
-- lied about having a CUSK. Error.
; let (meta_tvs, good_tvs) = partition isMetaTyVar qkvs
; when (not (null meta_tvs)) $
report_non_cusk_tvs (qkvs ++ tc_tvs)
-- If any of the scoped_kvs aren't actually mentioned in a binder's
-- kind (or the return kind), then we're in the CUSK case from
-- Note [Free-floating kind vars]
; let all_tc_tvs = good_tvs ++ tc_tvs
all_mentioned_tvs = mapUnionVarSet (tyCoVarsOfType . tyVarKind)
all_tc_tvs
`unionVarSet` tyCoVarsOfType res_kind
unmentioned_kvs = filterOut (`elemVarSet` all_mentioned_tvs)
scoped_kvs
; reportFloatingKvs name flav all_tc_tvs unmentioned_kvs
; let final_binders = map (mkNamedTyConBinder Specified) good_tvs
++ tc_binders
tycon = mkTcTyCon name final_binders res_kind
(scoped_kvs ++ tc_tvs) flav
-- the tvs contain the binders already
-- in scope from an enclosing class, but
-- re-adding tvs to the env't doesn't cause
-- harm
; traceTc "kcHsTyVarBndrs: cusk" $
vcat [ ppr name, ppr kv_ns, ppr hs_tvs, ppr dep_names
, ppr tc_binders, ppr (mkTyConKind tc_binders res_kind)
, ppr qkvs, ppr meta_tvs, ppr good_tvs, ppr final_binders ]
; return (tycon, stuff) }}
| otherwise
= do { kv_kinds <- mk_kv_kinds
; scoped_kvs <- zipWithM newSigTyVar kv_ns kv_kinds
-- the names must line up in splitTelescopeTvs
; (binders, res_kind, stuff)
<- tcExtendTyVarEnv2 (kv_ns `zip` scoped_kvs) $
bind_telescope hs_tvs thing_inside
; let -- NB: Don't add scoped_kvs to tyConTyVars, because they
-- must remain lined up with the binders
tycon = mkTcTyCon name binders res_kind
(scoped_kvs ++ binderVars binders) flav
; traceTc "kcHsTyVarBndrs: not-cusk" $
vcat [ ppr name, ppr kv_ns, ppr hs_tvs, ppr dep_names
, ppr binders, ppr (mkTyConKind binders res_kind) ]
; return (tycon, stuff) }
where
open_fam = tcFlavourIsOpen flav
-- if -XNoTypeInType and we know all the implicits are kind vars,
-- just give the kind *. This prevents test
-- dependent/should_fail/KindLevelsB from compiling, as it should
mk_kv_kinds :: TcM [Kind]
mk_kv_kinds = do { typeintype <- xoptM LangExt.TypeInType
; if not typeintype && all_kind_vars
then return (map (const liftedTypeKind) kv_ns)
else mapM (const newMetaKindVar) kv_ns }
-- there may be dependency between the explicit "ty" vars. So, we have
-- to handle them one at a time.
bind_telescope :: [LHsTyVarBndr GhcRn]
-> TcM (Kind, r)
-> TcM ([TyConBinder], TcKind, r)
bind_telescope [] thing
= do { (res_kind, stuff) <- thing
; return ([], res_kind, stuff) }
bind_telescope (L _ hs_tv : hs_tvs) thing
= do { tv_pair@(tv, _) <- kc_hs_tv hs_tv
-- NB: Bring all tvs into scope, even non-dependent ones,
-- as they're needed in type synonyms, data constructors, etc.
; (binders, res_kind, stuff) <- bind_unless_scoped tv_pair $
bind_telescope hs_tvs $
thing
-- See Note [Dependent LHsQTyVars]
; let new_binder | hsTyVarName hs_tv `elemNameSet` dep_names
= mkNamedTyConBinder Required tv
| otherwise
= mkAnonTyConBinder tv
; return ( new_binder : binders
, res_kind, stuff ) }
-- | Bind the tyvar in the env't unless the bool is True
bind_unless_scoped :: (TcTyVar, Bool) -> TcM a -> TcM a
bind_unless_scoped (_, True) thing_inside = thing_inside
bind_unless_scoped (tv, False) thing_inside
= tcExtendTyVarEnv [tv] thing_inside
kc_hs_tv :: HsTyVarBndr GhcRn -> TcM (TcTyVar, Bool)
kc_hs_tv (UserTyVar lname@(L _ name))
= do { tv_pair@(tv, scoped) <- tcHsTyVarName Nothing name
-- Open type/data families default their variables to kind *.
; when (open_fam && not scoped) $ -- (don't default class tyvars)
discardResult $ unifyKind (Just (HsTyVar NotPromoted lname)) liftedTypeKind
(tyVarKind tv)
; return tv_pair }
kc_hs_tv (KindedTyVar (L _ name) lhs_kind)
= do { kind <- tcLHsKindSig lhs_kind
; tcHsTyVarName (Just kind) name }
report_non_cusk_tvs all_tvs
= do { all_tvs <- mapM zonkTyCoVarKind all_tvs
; let (_, tidy_tvs) = tidyOpenTyCoVars emptyTidyEnv all_tvs
(meta_tvs, other_tvs) = partition isMetaTyVar tidy_tvs
; addErr $
vcat [ text "You have written a *complete user-suppled kind signature*,"
, hang (text "but the following variable" <> plural meta_tvs <+>
isOrAre meta_tvs <+> text "undetermined:")
2 (vcat (map pp_tv meta_tvs))
, text "Perhaps add a kind signature."
, hang (text "Inferred kinds of user-written variables:")
2 (vcat (map pp_tv other_tvs)) ] }
where
pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
tcImplicitTKBndrs :: [Name]
-> TcM (a, TyVarSet) -- vars are bound somewhere in the scope
-- see Note [Scope-check inferred kinds]
-> TcM ([TcTyVar], a)
tcImplicitTKBndrs = tcImplicitTKBndrsX (tcHsTyVarName Nothing)
-- | Convenient specialization
tcImplicitTKBndrsType :: [Name]
-> TcM Type
-> TcM ([TcTyVar], Type)
tcImplicitTKBndrsType var_ns thing_inside
= tcImplicitTKBndrs var_ns $
do { res_ty <- thing_inside
; return (res_ty, allBoundVariables res_ty) }
-- this more general variant is needed in tcHsPatSigType.
-- See Note [Pattern signature binders]
tcImplicitTKBndrsX :: (Name -> TcM (TcTyVar, Bool)) -- new_tv function
-> [Name]
-> TcM (a, TyVarSet)
-> TcM ([TcTyVar], a)
-- Returned TcTyVars have the supplied Names,
-- but may be in different order to the original [Name]
-- (because of sorting to respect dependency)
-- Returned TcTyVars have zonked kinds
tcImplicitTKBndrsX new_tv var_ns thing_inside
= do { tkvs_pairs <- mapM new_tv var_ns
; let must_scope_tkvs = [ tkv | (tkv, False) <- tkvs_pairs ]
tkvs = map fst tkvs_pairs
; (result, bound_tvs) <- tcExtendTyVarEnv must_scope_tkvs $
thing_inside
-- Check that the implicitly-bound kind variable
-- really can go at the beginning.
-- e.g. forall (a :: k) (b :: *). ...(forces k :: b)...
; tkvs <- mapM zonkTyCoVarKind tkvs
-- NB: /not/ zonkTcTyVarToTyVar. tcImplicitTKBndrsX
-- guarantees to return TcTyVars with the same Names
-- as the var_ns. See [Pattern signature binders]
; let extra = text "NB: Implicitly-bound variables always come" <+>
text "before other ones."
; checkValidInferredKinds tkvs bound_tvs extra
; let final_tvs = toposortTyVars tkvs
; traceTc "tcImplicitTKBndrs" (ppr var_ns $$ ppr final_tvs)
; return (final_tvs, result) }
tcExplicitTKBndrs :: [LHsTyVarBndr GhcRn]
-> ([TyVar] -> TcM (a, TyVarSet))
-- ^ Thing inside returns the set of variables bound
-- in the scope. See Note [Scope-check inferred kinds]
-> TcM (a, TyVarSet) -- ^ returns augmented bound vars
-- No cloning: returned TyVars have the same Name as the incoming LHsTyVarBndrs
tcExplicitTKBndrs orig_hs_tvs thing_inside
= tcExplicitTKBndrsX newSkolemTyVar orig_hs_tvs thing_inside
tcExplicitTKBndrsX :: (Name -> Kind -> TcM TyVar)
-> [LHsTyVarBndr GhcRn]
-> ([TyVar] -> TcM (a, TyVarSet))
-- ^ Thing inside returns the set of variables bound
-- in the scope. See Note [Scope-check inferred kinds]
-> TcM (a, TyVarSet) -- ^ returns augmented bound vars
tcExplicitTKBndrsX new_tv orig_hs_tvs thing_inside
= go orig_hs_tvs $ \ tvs ->
do { (result, bound_tvs) <- thing_inside tvs
-- Issue an error if the ordering is bogus.
-- See Note [Bad telescopes] in TcValidity.
; tvs <- checkZonkValidTelescope (interppSP orig_hs_tvs) tvs empty
; checkValidInferredKinds tvs bound_tvs empty
; traceTc "tcExplicitTKBndrs" $
vcat [ text "Hs vars:" <+> ppr orig_hs_tvs
, text "tvs:" <+> sep (map pprTyVar tvs) ]
; return (result, bound_tvs `unionVarSet` mkVarSet tvs)
}
where
go [] thing = thing []
go (L _ hs_tv : hs_tvs) thing
= do { tv <- tcHsTyVarBndr new_tv hs_tv
; tcExtendTyVarEnv [tv] $
go hs_tvs $ \ tvs ->
thing (tv : tvs) }
tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)
-> HsTyVarBndr GhcRn -> TcM TcTyVar
-- Return a SkolemTv TcTyVar, initialised with a kind variable.
-- Typically the Kind inside the HsTyVarBndr will be a tyvar
-- with a mutable kind in it.
-- NB: These variables must not be in scope. This function
-- is not appropriate for use with associated types, for example.
--
-- Returned TcTyVar has the same name; no cloning
--
-- See also Note [Associated type tyvar names] in Class
--
tcHsTyVarBndr new_tv (UserTyVar (L _ name))
= do { kind <- newMetaKindVar
; new_tv name kind }
tcHsTyVarBndr new_tv (KindedTyVar (L _ name) kind)
= do { kind <- tcLHsKindSig kind
; new_tv name kind }
newWildTyVar :: Name -> TcM TcTyVar
-- ^ New unification variable for a wildcard
newWildTyVar _name
= do { kind <- newMetaKindVar
; uniq <- newUnique
; details <- newMetaDetails TauTv
; let name = mkSysTvName uniq (fsLit "w")
; return (mkTcTyVar name kind details) }
-- | Produce a tyvar of the given name (with the kind provided, or
-- otherwise a meta-var kind). If
-- the name is already in scope, return the scoped variable, checking
-- to make sure the known kind matches any kind provided. The
-- second return value says whether the variable is in scope (True)
-- or not (False). (Use this for associated types, for example.)
tcHsTyVarName :: Maybe Kind -> Name -> TcM (TcTyVar, Bool)
tcHsTyVarName m_kind name
= do { mb_tv <- tcLookupLcl_maybe name
; case mb_tv of
Just (ATyVar _ tv)
-> do { whenIsJust m_kind $ \ kind ->
discardResult $
unifyKind (Just (HsTyVar NotPromoted (noLoc name))) kind (tyVarKind tv)
; return (tv, True) }
_ -> do { kind <- case m_kind of
Just kind -> return kind
Nothing -> newMetaKindVar
; tv <- newSkolemTyVar name kind
; return (tv, False) }}
-- makes a new skolem tv
newSkolemTyVar :: Name -> Kind -> TcM TcTyVar
newSkolemTyVar name kind = do { lvl <- getTcLevel
; return (mk_skolem_tv lvl name kind) }
mk_skolem_tv :: TcLevel -> Name -> Kind -> TcTyVar
mk_skolem_tv lvl n k = mkTcTyVar n k (SkolemTv lvl False)
------------------
kindGeneralizeType :: Type -> TcM Type
-- Result is zonked
kindGeneralizeType ty
= do { kvs <- kindGeneralize ty
; ty <- zonkSigType (mkInvForAllTys kvs ty)
; return ty }
kindGeneralize :: TcType -> TcM [KindVar]
-- Quantify the free kind variables of a kind or type
-- In the latter case the type is closed, so it has no free
-- type variables. So in both cases, all the free vars are kind vars
kindGeneralize kind_or_type
= do { kvs <- zonkTcTypeAndFV kind_or_type
; let dvs = DV { dv_kvs = kvs, dv_tvs = emptyDVarSet }
; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked
; quantifyTyVars gbl_tvs dvs }
{-
Note [Kind generalisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We do kind generalisation only at the outer level of a type signature.
For example, consider
T :: forall k. k -> *
f :: (forall a. T a -> Int) -> Int
When kind-checking f's type signature we generalise the kind at
the outermost level, thus:
f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES!
and *not* at the inner forall:
f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO!
Reason: same as for HM inference on value level declarations,
we want to infer the most general type. The f2 type signature
would be *less applicable* than f1, because it requires a more
polymorphic argument.
NB: There are no explicit kind variables written in f's signature.
When there are, the renamer adds these kind variables to the list of
variables bound by the forall, so you can indeed have a type that's
higher-rank in its kind. But only by explicit request.
Note [Kinds of quantified type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tcTyVarBndrsGen quantifies over a specified list of type variables,
*and* over the kind variables mentioned in the kinds of those tyvars.
Note that we must zonk those kinds (obviously) but less obviously, we
must return type variables whose kinds are zonked too. Example
(a :: k7) where k7 := k9 -> k9
We must return
[k9, a:k9->k9]
and NOT
[k9, a:k7]
Reason: we're going to turn this into a for-all type,
forall k9. forall (a:k7). blah
which the type checker will then instantiate, and instantiate does not
look through unification variables!
Hence using zonked_kinds when forming tvs'.
Note [Free-floating kind vars]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = MkT (forall (a :: k). Proxy a)
-- from test ghci/scripts/T7873
This is not an existential datatype, but a higher-rank one (the forall
to the right of MkT). Also consider
data S a = MkS (Proxy (a :: k))
According to the rules around implicitly-bound kind variables, in both
cases those k's scope over the whole declaration. The renamer grabs
it and adds it to the hsq_implicits field of the HsQTyVars of the
tycon. So it must be in scope during type-checking, but we want to
reject T while accepting S.
Why reject T? Because the kind variable isn't fixed by anything. For
a variable like k to be implicit, it needs to be mentioned in the kind
of a tycon tyvar. But it isn't.
Why accept S? Because kind inference tells us that a has kind k, so it's
all OK.
Our approach depends on whether or not the datatype has a CUSK.
Non-CUSK: In the first pass (kcTyClTyVars) we just bring
k into scope. In the second pass (tcTyClTyVars),
we check to make sure that k has been unified with some other variable
(or generalized over, making k into a skolem). If it hasn't been, then
it must be a free-floating kind var. Error.
CUSK: When we determine the tycon's final, never-to-be-changed kind
in kcHsTyVarBndrs, we check to make sure all implicitly-bound kind
vars are indeed mentioned in a kind somewhere. If not, error.
We also perform free-floating kind var analysis for type family instances
(see #13985). Here is an interesting example:
type family T :: k
type instance T = (Nothing :: Maybe a)
Upon a cursory glance, it may appear that the kind variable `a` is
free-floating above, since there are no (visible) LHS patterns in `T`. However,
there is an *invisible* pattern due to the return kind, so inside of GHC, the
instance looks closer to this:
type family T @k :: k
type instance T @(Maybe a) = (Nothing :: Maybe a)
Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in
fact not free-floating. Contrast that with this example:
type instance T = Proxy (Nothing :: Maybe a)
This would looks like this inside of GHC:
type instance T @(*) = Proxy (Nothing :: Maybe a)
So this time, `a` is neither bound by a visible nor invisible type pattern on
the LHS, so it would be reported as free-floating.
Finally, here's one more brain-teaser (from #9574). In the example below:
class Funct f where
type Codomain f :: *
instance Funct ('KProxy :: KProxy o) where
type Codomain 'KProxy = NatTr (Proxy :: o -> *)
As it turns out, `o` is not free-floating in this example. That is because `o`
bound by the kind signature of the LHS type pattern 'KProxy. To make this more
obvious, one can also write the instance like so:
instance Funct ('KProxy :: KProxy o) where
type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *)
-}
--------------------
-- getInitialKind 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.
kcLookupTcTyCon :: Name -> TcM TcTyCon
kcLookupTcTyCon nm
= do { tc_ty_thing <- tcLookup nm
; return $ case tc_ty_thing of
ATcTyCon tc -> tc
_ -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) }
-----------------------
-- | Bring tycon tyvars into scope. This is used during the "kind-checking"
-- pass in TcTyClsDecls. (Never in getInitialKind, never in the
-- "type-checking"/desugaring pass.)
-- Never emits constraints, though the thing_inside might.
kcTyClTyVars :: Name -> TcM a -> TcM a
kcTyClTyVars tycon_name thing_inside
= do { tycon <- kcLookupTcTyCon tycon_name
; tcExtendTyVarEnv (tcTyConScopedTyVars tycon) $ thing_inside }
tcTyClTyVars :: Name
-> ([TyConBinder] -> Kind -> TcM a) -> TcM a
-- ^ Used for the type variables of a type or class decl
-- on the second full pass (type-checking/desugaring) in TcTyClDecls.
-- This is *not* used in the initial-kind run, nor in the "kind-checking" pass.
-- Accordingly, everything passed to the continuation is fully zonked.
--
-- (tcTyClTyVars T [a,b] thing_inside)
-- where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> *
-- calls thing_inside with arguments
-- [k1,k2,a,b] [k1:*, k2:*, Anon (k1 -> *), Anon k1] (k2 -> *)
-- having also extended the type environment with bindings
-- for k1,k2,a,b
--
-- Never emits constraints.
--
-- The LHsTyVarBndrs is always user-written, and the full, generalised
-- kind of the tycon is available in the local env.
tcTyClTyVars tycon_name thing_inside
= do { tycon <- kcLookupTcTyCon tycon_name
; let scoped_tvs = tcTyConScopedTyVars tycon
-- these are all zonked:
res_kind = tyConResKind tycon
binders = correct_binders (tyConBinders tycon) res_kind
-- See Note [Free-floating kind vars]
; zonked_scoped_tvs <- mapM zonkTcTyVarToTyVar scoped_tvs
; let still_sig_tvs = filter isSigTyVar zonked_scoped_tvs
; checkNoErrs $ reportFloatingKvs tycon_name (tyConFlavour tycon)
zonked_scoped_tvs still_sig_tvs
-- Add the *unzonked* tyvars to the env't, because those
-- are the ones mentioned in the source.
; traceTc "tcTyClTyVars" (ppr tycon_name <+> ppr binders)
; tcExtendTyVarEnv scoped_tvs $
thing_inside binders res_kind }
where
-- Given some TyConBinders and a TyCon's result kind, make sure that the
-- correct any wrong Named/Anon choices. For example, consider
-- type Syn k = forall (a :: k). Proxy a
-- At first, it looks like k should be named -- after all, it appears on the RHS.
-- However, the correct kind for Syn is (* -> *).
-- (Why? Because k is the kind of a type, so k's kind is *. And the RHS also has
-- kind *.) See also #13963.
correct_binders :: [TyConBinder] -> Kind -> [TyConBinder]
correct_binders binders kind
= binders'
where
(_, binders') = mapAccumR go (tyCoVarsOfType kind) binders
go :: TyCoVarSet -> TyConBinder -> (TyCoVarSet, TyConBinder)
go fvs binder
| isNamedTyConBinder binder
, not (tv `elemVarSet` fvs)
= (new_fvs, mkAnonTyConBinder tv)
| not (isNamedTyConBinder binder)
, tv `elemVarSet` fvs
= (new_fvs, mkNamedTyConBinder Required tv)
-- always Required, because it was anonymous (i.e. visible) previously
| otherwise
= (new_fvs, binder)
where
tv = binderVar binder
new_fvs = fvs `delVarSet` tv `unionVarSet` tyCoVarsOfType (tyVarKind tv)
-----------------------------------
data DataKindCheck
-- Plain old data type; better be lifted
= LiftedDataKind
-- Data families might have a variable return kind.
-- See See Note [Arity of data families] in FamInstEnv for more info.
| LiftedOrVarDataKind
-- Abstract data in hsig files can have any kind at all;
-- even unlifted. This is because they might not actually
-- be implemented with a data declaration at the end of the day.
| AnyDataKind
tcDataKindSig :: DataKindCheck -- ^ Do we require the result to be *?
-> Kind -> TcM ([TyConBinder], Kind)
-- GADT decls can have a (perhaps partial) kind signature
-- e.g. data T :: * -> * -> * where ...
-- This function makes up suitable (kinded) type variables for
-- the argument kinds, and checks that the result kind is indeed * if requested.
-- (Otherwise, checks to make sure that the result kind is either * or a type variable.)
-- See Note [Arity of data families] in FamInstEnv for more info.
-- We use it also to make up argument type variables for for data instances.
-- Never emits constraints.
-- Returns the new TyVars, the extracted TyBinders, and the new, reduced
-- result kind (which should always be Type or a synonym thereof)
tcDataKindSig kind_check kind
= do { case kind_check of
LiftedDataKind ->
checkTc (isLiftedTypeKind res_kind)
(badKindSig True kind)
LiftedOrVarDataKind ->
checkTc (isLiftedTypeKind res_kind || isJust (tcGetCastedTyVar_maybe res_kind))
(badKindSig False kind)
AnyDataKind -> return ()
; span <- getSrcSpanM
; us <- newUniqueSupply
; rdr_env <- getLocalRdrEnv
; let uniqs = uniqsFromSupply us
occs = [ occ | str <- allNameStrings
, let occ = mkOccName tvName str
, isNothing (lookupLocalRdrOcc rdr_env occ) ]
-- Note [Avoid name clashes for associated data types]
-- NB: Use the tv from a binder if there is one. Otherwise,
-- we end up inventing a new Unique for it, and any other tv
-- that mentions the first ends up with the wrong kind.
extra_bndrs = zipWith4 mkTyBinderTyConBinder
tv_bndrs (repeat span) uniqs occs
; return (extra_bndrs, res_kind) }
where
(tv_bndrs, res_kind) = splitPiTys kind
badKindSig :: Bool -> Kind -> SDoc
badKindSig check_for_type kind
= hang (sep [ text "Kind signature on data type declaration has non-*"
, (if check_for_type then empty else text "and non-variable") <+>
text "return kind" ])
2 (ppr kind)
{-
Note [Avoid name clashes for associated data types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider class C a b where
data D b :: * -> *
When typechecking the decl for D, we'll invent an extra type variable
for D, to fill out its kind. Ideally we don't want this type variable
to be 'a', because when pretty printing we'll get
class C a b where
data D b a0
(NB: the tidying happens in the conversion to IfaceSyn, which happens
as part of pretty-printing a TyThing.)
That's why we look in the LocalRdrEnv to see what's in scope. This is
important only to get nice-looking output when doing ":info C" in GHCi.
It isn't essential for correctness.
************************************************************************
* *
Partial signatures
* *
************************************************************************
-}
tcHsPartialSigType
:: UserTypeCtxt
-> LHsSigWcType GhcRn -- The type signature
-> TcM ( [(Name, TcTyVar)] -- Wildcards
, Maybe TcTyVar -- Extra-constraints wildcard
, [TcTyVar] -- Implicitly and explicitly bound type variables
, TcThetaType -- Theta part
, TcType ) -- Tau part
tcHsPartialSigType ctxt sig_ty
| HsWC { hswc_wcs = sig_wcs, hswc_body = ib_ty } <- sig_ty
, HsIB { hsib_vars = implicit_hs_tvs, hsib_body = hs_ty } <- ib_ty
, (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty
= addSigCtxt ctxt hs_ty $
do { (implicit_tvs, (wcs, wcx, explicit_tvs, theta, tau))
<- tcWildCardBindersX newWildTyVar sig_wcs $ \ wcs ->
tcImplicitTKBndrsX new_implicit_tv implicit_hs_tvs $
tcExplicitTKBndrsX newSigTyVar explicit_hs_tvs $ \ explicit_tvs ->
do { -- Instantiate the type-class context; but if there
-- is an extra-constraints wildcard, just discard it here
(theta, wcx) <- tcPartialContext hs_ctxt
; tau <- tcHsOpenType hs_tau
; let bound_tvs = unionVarSets [ allBoundVariables tau
, mkVarSet explicit_tvs
, mkVarSet (map snd wcs) ]
; return ( (wcs, wcx, explicit_tvs, theta, tau)
, bound_tvs) }
-- Spit out the wildcards (including the extra-constraints one)
-- as "hole" constraints, so that they'll be reported if necessary
-- See Note [Extra-constraint holes in partial type signatures]
; emitWildCardHoleConstraints wcs
; explicit_tvs <- mapM zonkTyCoVarKind explicit_tvs
; let all_tvs = implicit_tvs ++ explicit_tvs
-- The implicit_tvs already have zonked kinds
; theta <- mapM zonkTcType theta
; tau <- zonkTcType tau
; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau)
; traceTc "tcHsPartialSigType" (ppr all_tvs)
; return (wcs, wcx, all_tvs, theta, tau) }
where
new_implicit_tv name = do { kind <- newMetaKindVar
; tv <- newSigTyVar name kind
; return (tv, False) }
tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcTyVar)
tcPartialContext hs_theta
| Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta
, L _ (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
= do { wc_tv <- tcWildCardOcc wc constraintKind
; theta <- mapM tcLHsPredType hs_theta1
; return (theta, Just wc_tv) }
| otherwise
= do { theta <- mapM tcLHsPredType hs_theta
; return (theta, Nothing) }
{- Note [Extra-constraint holes in partial type signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f :: (_) => a -> a
f x = ...
* The renamer makes a wildcard name for the "_", and puts it in
the hswc_wcs field.
* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in
tcWildCardBindersX.
* TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar
with the inferred constraints, e.g. (Eq a, Show a)
* TcErrors.mkHoleError finally reports the error.
An annoying difficulty happens if there are more than 62 inferred
constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.
Where do we find the TyCon? For good reasons we only have constraint
tuples up to 62 (see Note [How tuples work] in TysWiredIn). So how
can we make a 70-tuple? This was the root cause of Trac #14217.
It's incredibly tiresome, because we only need this type to fill
in the hole, to communicate to the error reporting machinery. Nothing
more. So I use a HACK:
* I make an /ordinary/ tuple of the constraints, in
TcBinds.chooseInferredQuantifiers. This is ill-kinded because
ordinary tuples can't contain constraints, but it works fine. And for
ordinary tuples we don't have the same limit as for constraint
tuples (which need selectors and an assocated class).
* Because it is ill-kinded, it trips an assert in writeMetaTyVar,
so now I disable the assertion if we are writing a type of
kind Constraint. (That seldom/never normally happens so we aren't
losing much.)
Result works fine, but it may eventually bite us.
************************************************************************
* *
Pattern signatures (i.e signatures that occur in patterns)
* *
********************************************************************* -}
tcHsPatSigType :: UserTypeCtxt
-> LHsSigWcType GhcRn -- The type signature
-> TcM ( [(Name, TcTyVar)] -- Wildcards
, [(Name, TcTyVar)] -- The new bit of type environment, binding
-- the scoped type variables
, TcType) -- The type
-- Used for type-checking type signatures in
-- (a) patterns e.g f (x::Int) = e
-- (b) RULE forall bndrs e.g. forall (x::Int). f x = x
--
-- This may emit constraints
tcHsPatSigType ctxt sig_ty
| HsWC { hswc_wcs = sig_wcs, hswc_body = ib_ty } <- sig_ty
, HsIB { hsib_vars = sig_vars, hsib_body = hs_ty } <- ib_ty
= addSigCtxt ctxt hs_ty $
do { (implicit_tvs, (wcs, sig_ty))
<- tcWildCardBindersX newWildTyVar sig_wcs $ \ wcs ->
tcImplicitTKBndrsX new_implicit_tv sig_vars $
do { sig_ty <- tcHsOpenType hs_ty
; return ((wcs, sig_ty), allBoundVariables sig_ty) }
; emitWildCardHoleConstraints wcs
; sig_ty <- zonkTcType sig_ty
; checkValidType ctxt sig_ty
; tv_pairs <- mapM mk_tv_pair implicit_tvs
; traceTc "tcHsPatSigType" (ppr sig_vars)
; return (wcs, tv_pairs, sig_ty) }
where
new_implicit_tv name = do { kind <- newMetaKindVar
; tv <- new_tv name kind
; return (tv, False) }
-- "False" means that these tyvars aren't yet in scope
new_tv = case ctxt of
RuleSigCtxt {} -> newSkolemTyVar
_ -> newSigTyVar
-- See Note [Pattern signature binders]
-- See Note [Unifying SigTvs]
mk_tv_pair tv = do { tv' <- zonkTcTyVarToTyVar tv
; return (tyVarName tv, tv') }
-- The Name is one of sig_vars, the lexically scoped name
-- But if it's a SigTyVar, it might have been unified
-- with an existing in-scope skolem, so we must zonk
-- here. See Note [Pattern signature binders]
tcPatSig :: Bool -- True <=> pattern binding
-> LHsSigWcType GhcRn
-> ExpSigmaType
-> TcM (TcType, -- The type to use for "inside" the signature
[(Name,TcTyVar)], -- The new bit of type environment, binding
-- the scoped type variables
[(Name,TcTyVar)], -- The wildcards
HsWrapper) -- Coercion due to unification with actual ty
-- Of shape: res_ty ~ sig_ty
tcPatSig in_pat_bind sig res_ty
= do { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig
-- sig_tvs are the type variables free in 'sig',
-- and not already in scope. These are the ones
-- that should be brought into scope
; if null sig_tvs then do {
-- Just do the subsumption check and return
wrap <- addErrCtxtM (mk_msg sig_ty) $
tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty
; return (sig_ty, [], sig_wcs, wrap)
} else do
-- Type signature binds at least one scoped type variable
-- A pattern binding cannot bind scoped type variables
-- It is more convenient to make the test here
-- than in the renamer
{ when in_pat_bind (addErr (patBindSigErr sig_tvs))
-- Check that all newly-in-scope tyvars are in fact
-- constrained by the pattern. This catches tiresome
-- cases like
-- type T a = Int
-- f :: Int -> Int
-- f (x :: T a) = ...
-- Here 'a' doesn't get a binding. Sigh
; let bad_tvs = [ tv | (_,tv) <- sig_tvs
, not (tv `elemVarSet` exactTyCoVarsOfType sig_ty) ]
; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs)
-- Now do a subsumption check of the pattern signature against res_ty
; wrap <- addErrCtxtM (mk_msg sig_ty) $
tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty
-- Phew!
; return (sig_ty, sig_tvs, sig_wcs, wrap)
} }
where
mk_msg sig_ty tidy_env
= do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty
; res_ty <- readExpType res_ty -- should be filled in by now
; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty
; let msg = vcat [ hang (text "When checking that the pattern signature:")
4 (ppr sig_ty)
, nest 2 (hang (text "fits the type of its context:")
2 (ppr res_ty)) ]
; return (tidy_env, msg) }
patBindSigErr :: [(Name,TcTyVar)] -> SDoc
patBindSigErr sig_tvs
= hang (text "You cannot bind scoped type variable" <> plural sig_tvs
<+> pprQuotedList (map fst sig_tvs))
2 (text "in a pattern binding signature")
{- Note [Pattern signature binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = forall a. T a (a->Int)
f (T x (f :: b->Int)) = blah
Here
* The pattern (T p1 p2) creates a *skolem* type variable 'a_sk',
It must be a skolem so that that it retains its identity, and
TcErrors.getSkolemInfo can thereby find the binding site for the skolem.
* The type signature pattern (f :: b->Int) makes a fresh meta-tyvar b_sig
(a SigTv), and binds "b" :-> b_sig in the envt
* Then unification makes b_sig := a_sk
That's why we must make b_sig a MetaTv (albeit a SigTv),
not a SkolemTv, so that it can unify to a_sk.
* Finally, in 'blah' we must have the envt "b" :-> a_sk. The pair
("b" :-> a_sk) is returned by tcHsPatSigType, constructed by
mk_tv_pair in that function.
Another example (Trac #13881):
fl :: forall (l :: [a]). Sing l -> Sing l
fl (SNil :: Sing (l :: [y])) = SNil
When we reach the pattern signature, 'l' is in scope from the
outer 'forall':
"a" :-> a_sk :: *
"l" :-> l_sk :: [a_sk]
We make up a fresh meta-SigTv, y_sig, for 'y', and kind-check
the pattern signature
Sing (l :: [y])
That unifies y_sig := a_sk. We return from tcHsPatSigType with
the pair ("y" :-> a_sk).
For RULE binders, though, things are a bit different (yuk).
RULE "foo" forall (x::a) (y::[a]). f x y = ...
Here this really is the binding site of the type variable so we'd like
to use a skolem, so that we get a complaint if we unify two of them
together.
Note [Unifying SigTvs]
~~~~~~~~~~~~~~~~~~~~~~
ALAS we have no decent way of avoiding two SigTvs getting unified.
Consider
f (x::(a,b)) (y::c)) = [fst x, y]
Here we'd really like to complain that 'a' and 'c' are unified. But
for the reasons above we can't make a,b,c into skolems, so they
are just SigTvs that can unify. And indeed, this would be ok,
f x (y::c) = case x of
(x1 :: a1, True) -> [x,y]
(x1 :: a2, False) -> [x,y,y]
Here the type of x's first component is called 'a1' in one branch and
'a2' in the other. We could try insisting on the same OccName, but
they definitely won't have the sane lexical Name.
I think we could solve this by recording in a SigTv a list of all the
in-scope variables that it should not unify with, but it's fiddly.
************************************************************************
* *
Checking kinds
* *
************************************************************************
-}
unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)
unifyKinds rn_tys act_kinds
= do { kind <- newMetaKindVar
; let check rn_ty (ty, act_kind) = checkExpectedKind (unLoc rn_ty) ty act_kind kind
; tys' <- zipWithM check rn_tys act_kinds
; return (tys', kind) }
{-
************************************************************************
* *
Sort checking kinds
* *
************************************************************************
tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.
It does sort checking and desugaring at the same time, in one single pass.
-}
tcLHsKindSig :: LHsKind GhcRn -> TcM Kind
tcLHsKindSig hs_kind
= do { kind <- tc_lhs_kind kindLevelMode hs_kind
; zonkTcType kind }
-- This zonk is very important in the case of higher rank kinds
-- E.g. Trac #13879 f :: forall (p :: forall z (y::z). <blah>).
-- <more blah>
-- When instantiating p's kind at occurrences of p in <more blah>
-- it's crucial that the kind we instantiate is fully zonked,
-- else we may fail to substitute properly
tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind
tc_lhs_kind mode k
= addErrCtxt (text "In the kind" <+> quotes (ppr k)) $
tc_lhs_type (kindLevel mode) k liftedTypeKind
promotionErr :: Name -> PromotionErr -> TcM a
promotionErr name err
= failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")
2 (parens reason))
where
reason = case err of
FamDataConPE -> text "it comes from a data family instance"
NoDataKindsTC -> text "Perhaps you intended to use DataKinds"
NoDataKindsDC -> text "Perhaps you intended to use DataKinds"
NoTypeInTypeTC -> text "Perhaps you intended to use TypeInType"
NoTypeInTypeDC -> text "Perhaps you intended to use TypeInType"
PatSynPE -> text "Pattern synonyms cannot be promoted"
_ -> text "it is defined and used in the same recursive group"
{-
************************************************************************
* *
Scoped type variables
* *
************************************************************************
-}
badPatSigTvs :: TcType -> [TyVar] -> SDoc
badPatSigTvs sig_ty bad_tvs
= vcat [ fsep [text "The type variable" <> plural bad_tvs,
quotes (pprWithCommas ppr bad_tvs),
text "should be bound by the pattern signature" <+> quotes (ppr sig_ty),
text "but are actually discarded by a type synonym" ]
, text "To fix this, expand the type synonym"
, text "[Note: I hope to lift this restriction in due course]" ]
{-
************************************************************************
* *
Error messages and such
* *
************************************************************************
-}
-- | Make an appropriate message for an error in a function argument.
-- Used for both expressions and types.
funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc
funAppCtxt fun arg arg_no
= hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"),
quotes (ppr fun) <> text ", namely"])
2 (quotes (ppr arg))
-- See Note [Free-floating kind vars]
reportFloatingKvs :: Name -- of the tycon
-> TyConFlavour -- What sort of TyCon it is
-> [TcTyVar] -- all tyvars, not necessarily zonked
-> [TcTyVar] -- floating tyvars
-> TcM ()
reportFloatingKvs tycon_name flav all_tvs bad_tvs
= unless (null bad_tvs) $ -- don't bother zonking if there's no error
do { all_tvs <- mapM zonkTcTyVarToTyVar all_tvs
; bad_tvs <- mapM zonkTcTyVarToTyVar bad_tvs
; let (tidy_env, tidy_all_tvs) = tidyOpenTyCoVars emptyTidyEnv all_tvs
tidy_bad_tvs = map (tidyTyVarOcc tidy_env) bad_tvs
; typeintype <- xoptM LangExt.TypeInType
; mapM_ (report typeintype tidy_all_tvs) tidy_bad_tvs }
where
report typeintype tidy_all_tvs tidy_bad_tv
= addErr $
vcat [ text "Kind variable" <+> quotes (ppr tidy_bad_tv) <+>
text "is implicitly bound in" <+> ppr flav
, quotes (ppr tycon_name) <> comma <+>
text "but does not appear as the kind of any"
, text "of its type variables. Perhaps you meant"
, text "to bind it" <+> ppWhen (not typeintype)
(text "(with TypeInType)") <+>
text "explicitly somewhere?"
, ppWhen (not (null tidy_all_tvs)) $
hang (text "Type variables with inferred kinds:")
2 (ppr_tv_bndrs tidy_all_tvs) ]
ppr_tv_bndrs tvs = sep (map pp_tv tvs)
pp_tv tv = parens (ppr tv <+> dcolon <+> ppr (tyVarKind tv))
|