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
|
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-- | Handles @deriving@ clauses on @data@ declarations.
module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where
import GHC.Prelude
import GHC.Hs
import GHC.Driver.Session
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Instance.Family
import GHC.Tc.Types.Origin
import GHC.Tc.Deriv.Infer
import GHC.Tc.Deriv.Utils
import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault )
import GHC.Tc.Utils.Env
import GHC.Tc.Deriv.Generate
import GHC.Tc.Validity( allDistinctTyVars, checkValidInstHead )
import GHC.Core.InstEnv
import GHC.Tc.Utils.Instantiate
import GHC.Core.FamInstEnv
import GHC.Tc.Gen.HsType
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr ( pprTyVars )
import GHC.Rename.Bind
import GHC.Rename.Env
import GHC.Rename.Module ( addTcgDUs )
import GHC.Rename.Utils
import GHC.Core.Unify( tcUnifyTy )
import GHC.Core.Class
import GHC.Core.Type
import GHC.Utils.Error
import GHC.Core.DataCon
import GHC.Data.Maybe
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Name.Set as NameSet
import GHC.Core.TyCon
import GHC.Tc.Utils.TcType
import GHC.Types.Var as Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Builtin.Names
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Logger
import GHC.Data.Bag
import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs)
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.List (partition, find)
{-
************************************************************************
* *
Overview
* *
************************************************************************
Overall plan
~~~~~~~~~~~~
1. Convert the decls (i.e. data/newtype deriving clauses,
plus standalone deriving) to [EarlyDerivSpec]
2. Infer the missing contexts for the InferTheta's
3. Add the derived bindings, generating InstInfos
-}
data EarlyDerivSpec = InferTheta (DerivSpec ThetaSpec)
| GivenTheta (DerivSpec ThetaType)
-- InferTheta ds => the context for the instance should be inferred
-- In this case ds_theta is the list of all the sets of
-- constraints needed, such as (Eq [a], Eq a), together with a
-- suitable CtLoc to get good error messages.
-- The inference process is to reduce this to a
-- simpler form (e.g. Eq a)
--
-- GivenTheta ds => the exact context for the instance is supplied
-- by the programmer; it is ds_theta
-- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer
splitEarlyDerivSpec :: [EarlyDerivSpec]
-> ([DerivSpec ThetaSpec], [DerivSpec ThetaType])
splitEarlyDerivSpec [] = ([],[])
splitEarlyDerivSpec (InferTheta spec : specs) =
case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
splitEarlyDerivSpec (GivenTheta spec : specs) =
case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)
instance Outputable EarlyDerivSpec where
ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
{-
Note [Data decl contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
We will need an instance decl like:
instance (Read a, RealFloat a) => Read (Complex a) where
...
The RealFloat in the context is because the read method for Complex is bound
to construct a Complex, and doing that requires that the argument type is
in RealFloat.
But this ain't true for Show, Eq, Ord, etc, since they don't construct
a Complex; they only take them apart.
Our approach: identify the offending classes, and add the data type
context to the instance decl. The "offending classes" are
Read, Enum?
FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that
pattern matching against a constructor from a data type with a context
gives rise to the constraints for that context -- or at least the thinned
version. So now all classes are "offending".
Note [Newtype deriving]
~~~~~~~~~~~~~~~~~~~~~~~
Consider this:
class C a b
instance C [a] Char
newtype T = T Char deriving( C [a] )
Notice the free 'a' in the deriving. We have to fill this out to
newtype T = T Char deriving( forall a. C [a] )
And then translate it to:
instance C [a] Char => C [a] T where ...
Note [Unused constructors and deriving clauses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #3221. Consider
data T = T1 | T2 deriving( Show )
Are T1 and T2 unused? Well, no: the deriving clause expands to mention
both of them. So we gather defs/uses from deriving just like anything else.
-}
-- | Stuff needed to process a datatype's `deriving` clauses
data DerivInfo = DerivInfo { di_rep_tc :: TyCon
-- ^ The data tycon for normal datatypes,
-- or the *representation* tycon for data families
, di_scoped_tvs :: ![(Name,TyVar)]
-- ^ Variables that scope over the deriving clause.
-- See @Note [Scoped tyvars in a TcTyCon]@ in
-- "GHC.Core.TyCon".
, di_clauses :: [LHsDerivingClause GhcRn]
, di_ctxt :: SDoc -- ^ error context
}
{-
************************************************************************
* *
Top-level function for \tr{derivings}
* *
************************************************************************
-}
tcDeriving :: [DerivInfo] -- All `deriving` clauses
-> [LDerivDecl GhcRn] -- All stand-alone deriving declarations
-> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
tcDeriving deriv_infos deriv_decls
= recoverM (do { g <- getGblEnv
; return (g, emptyBag, emptyValBindsOut)}) $
do { -- Fish the "deriving"-related information out of the GHC.Tc.Utils.Env
-- And make the necessary "equations".
early_specs <- makeDerivSpecs deriv_infos deriv_decls
; traceTc "tcDeriving" (ppr early_specs)
; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
; famInsts1 <- concatMapM genFamInsts given_specs
; famInsts2 <- concatMapM genFamInsts infer_specs
; let famInsts = famInsts1 ++ famInsts2
; dflags <- getDynFlags
; logger <- getLogger
-- We must put all the derived type family instances (from both
-- infer_specs and given_specs) in the local instance environment
-- before proceeding, or else simplifyInstanceContexts might
-- get stuck if it has to reason about any of those family instances.
-- See Note [Staging of tcDeriving]
; tcExtendLocalFamInstEnv famInsts $
-- NB: only call tcExtendLocalFamInstEnv once, as it performs
-- validity checking for all of the family instances you give it.
-- If the family instances have errors, calling it twice will result
-- in duplicate error messages!
do { given_inst_binds <- mapM genInstBinds given_specs
; let given_inst_infos = map fstOf3 given_inst_binds
-- the stand-alone derived instances (@given_inst_infos@) are used when
-- inferring the contexts for "deriving" clauses' instances
-- (@infer_specs@)
; final_infer_specs <-
extendLocalInstEnv (map iSpec given_inst_infos) $
simplifyInstanceContexts infer_specs
; infer_inst_binds <- mapM genInstBinds final_infer_specs
; let (_, aux_specs, fvs) = unzip3 (given_inst_binds ++ infer_inst_binds)
; loc <- getSrcSpanM
; let aux_binds = genAuxBinds dflags loc (unionManyBags aux_specs)
; let infer_inst_infos = map fstOf3 infer_inst_binds
; let inst_infos = given_inst_infos ++ infer_inst_infos
; (inst_info, rn_aux_binds, rn_dus) <- renameDeriv inst_infos aux_binds
; unless (isEmptyBag inst_info) $
liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Derived instances"
FormatHaskell
(ddump_deriving inst_info rn_aux_binds famInsts))
; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))
getGblEnv
; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)
; return (addTcgDUs gbl_env all_dus, inst_info, rn_aux_binds) } }
where
ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn
-> [FamInst] -- Associated type family instances
-> SDoc
ddump_deriving inst_infos extra_binds famInsts
= hang (text "Derived class instances:")
2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
$$ ppr extra_binds)
$$ hangP (text "Derived type family instances:")
(vcat (map pprRepTy famInsts))
hangP s x = text "" $$ hang s 2 x
-- Prints the representable type family instance
pprRepTy :: FamInst -> SDoc
pprRepTy fi@(FamInst { fi_tys = lhs })
= text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
equals <+> ppr rhs
where rhs = famInstRHS fi
renameDeriv :: [InstInfo GhcPs]
-> Bag (LHsBind GhcPs, LSig GhcPs)
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
renameDeriv inst_infos bagBinds
= discardWarnings $
-- Discard warnings about unused bindings etc
setXOptM LangExt.EmptyCase $
-- Derived decls (for empty types) can have
-- case x of {}
setXOptM LangExt.ScopedTypeVariables $
setXOptM LangExt.KindSignatures $
-- Derived decls (for newtype-deriving) can use ScopedTypeVariables &
-- KindSignatures
setXOptM LangExt.TypeApplications $
-- GND/DerivingVia uses TypeApplications in generated code
-- (See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate)
unsetXOptM LangExt.RebindableSyntax $
-- See Note [Avoid RebindableSyntax when deriving]
setXOptM LangExt.TemplateHaskellQuotes $
-- DeriveLift makes uses of quotes
do {
-- Bring the extra deriving stuff into scope
-- before renaming the instances themselves
; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
; let (aux_binds, aux_sigs) = unzipBag bagBinds
aux_val_binds = ValBinds NoAnnSortKey aux_binds (bagToList aux_sigs)
-- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename
-- auxiliary bindings as if they were defined locally.
-- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyFsEnv aux_val_binds
; bindLocalNames bndrs $
do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs
; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
; return (listToBag rn_inst_infos, rn_aux,
dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
where
rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)
rn_inst_info
inst_info@(InstInfo { iSpec = inst
, iBinds = InstBindings
{ ib_binds = binds
, ib_tyvars = tyvars
, ib_pragmas = sigs
, ib_extensions = exts -- Only for type-checking
, ib_derived = sa } })
= do { (rn_binds, rn_sigs, fvs) <- rnMethodBinds False (is_cls_nm inst)
tyvars binds sigs
; let binds' = InstBindings { ib_binds = rn_binds
, ib_tyvars = tyvars
, ib_pragmas = rn_sigs
, ib_extensions = exts
, ib_derived = sa }
; return (inst_info { iBinds = binds' }, fvs) }
{-
Note [Staging of tcDeriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here's a tricky corner case for deriving (adapted from #2721):
class C a where
type T a
foo :: a -> T a
instance C Int where
type T Int = Int
foo = id
newtype N = N Int deriving C
This will produce an instance something like this:
instance C N where
type T N = T Int
foo = coerce (foo :: Int -> T Int) :: N -> T N
We must be careful in order to typecheck this code. When determining the
context for the instance (in simplifyInstanceContexts), we need to determine
that T N and T Int have the same representation, but to do that, the T N
instance must be in the local family instance environment. Otherwise, GHC
would be unable to conclude that T Int is representationally equivalent to
T Int, and simplifyInstanceContexts would get stuck.
Previously, tcDeriving would defer adding any derived type family instances to
the instance environment until the very end, which meant that
simplifyInstanceContexts would get called without all the type family instances
it needed in the environment in order to properly simplify instance like
the C N instance above.
To avoid this scenario, we generate things in tcDeriving in a specific order:
1. First, we generate all of the associated type family instances for derived
instances (using `genFamInsts`).
2. Next, we extend the local instance environment with these type family
instances.
3. Then, we generate the instance bindings for derived instances
(using `genInstBinds`).
4. Finally, for instances generated with `deriving` clauses, we infer the
instance contexts (using `simplifyInstanceContexts`). At this point, we
already have the necessary type family instances in scope (from step (2)),
so this is safe to do.
Note [Why we don't pass rep_tc into deriveTyData]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc
back into the rep_tc by means of a lookup. And yet we have the rep_tc right
here! Why look it up again? Answer: it's just easier this way.
We drop some number of arguments from the end of the datatype definition
in deriveTyData. The arguments are dropped from the fam_tc.
This action may drop a *different* number of arguments
passed to the rep_tc, depending on how many free variables, etc., the
dropped patterns have.
Also, this technique carries over the kind substitution from deriveTyData
nicely.
Note [Avoid RebindableSyntax when deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The RebindableSyntax extension interacts awkwardly with the derivation of
any stock class whose methods require the use of string literals. The Show
class is a simple example (see #12688):
{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
newtype Text = Text String
fromString :: String -> Text
fromString = Text
data Foo = Foo deriving Show
This will generate code to the effect of:
instance Show Foo where
showsPrec _ Foo = showString "Foo"
But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"
string literal is now of type Text, not String, which showString doesn't
accept! This causes the generated Show instance to fail to typecheck.
To avoid this kind of scenario, we simply turn off RebindableSyntax entirely
in derived code.
************************************************************************
* *
From HsSyn to DerivSpec
* *
************************************************************************
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
-}
makeDerivSpecs :: [DerivInfo]
-> [LDerivDecl GhcRn]
-> TcM [EarlyDerivSpec]
makeDerivSpecs deriv_infos deriv_decls
= do { eqns1 <- sequenceA
-- MP: scoped_tvs here magically converts TyVar into TcTyVar
[ deriveClause rep_tc scoped_tvs dcs (deriv_clause_preds dct) err_ctxt
| DerivInfo { di_rep_tc = rep_tc
, di_scoped_tvs = scoped_tvs
, di_clauses = clauses
, di_ctxt = err_ctxt } <- deriv_infos
, L _ (HsDerivingClause { deriv_clause_strategy = dcs
, deriv_clause_tys = dct })
<- clauses
]
; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
; return $ concat eqns1 ++ catMaybes eqns2 }
where
deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
deriv_clause_preds (L _ dct) = case dct of
DctSingle _ ty -> [ty]
DctMulti _ tys -> tys
------------------------------------------------------------------
-- | Process the derived classes in a single @deriving@ clause.
deriveClause :: TyCon
-> [(Name, TcTyVar)] -- Scoped type variables taken from tcTyConScopedTyVars
-- See Note [Scoped tyvars in a TcTyCon] in "GHC.Core.TyCon"
-> Maybe (LDerivStrategy GhcRn)
-> [LHsSigType GhcRn] -> SDoc
-> TcM [EarlyDerivSpec]
deriveClause rep_tc scoped_tvs mb_lderiv_strat deriv_preds err_ctxt
= addErrCtxt err_ctxt $ do
traceTc "deriveClause" $ vcat
[ text "tvs" <+> ppr tvs
, text "scoped_tvs" <+> ppr scoped_tvs
, text "tc" <+> ppr tc
, text "tys" <+> ppr tys
, text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ]
tcExtendNameTyVarEnv scoped_tvs $ do
(mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat
tcExtendTyVarEnv via_tvs $
-- Moreover, when using DerivingVia one can bind type variables in
-- the `via` type as well, so these type variables must also be
-- brought into scope.
mapMaybeM (derivePred tc tys mb_lderiv_strat' via_tvs) deriv_preds
-- After typechecking the `via` type once, we then typecheck all
-- of the classes associated with that `via` type in the
-- `deriving` clause.
-- See also Note [Don't typecheck too much in DerivingVia].
where
tvs = tyConTyVars rep_tc
(tc, tys) = case tyConFamInstSig_maybe rep_tc of
-- data family:
Just (fam_tc, pats, _) -> (fam_tc, pats)
-- NB: deriveTyData wants the *user-specified*
-- name. See Note [Why we don't pass rep_tc into deriveTyData]
_ -> (rep_tc, mkTyVarTys tvs) -- datatype
-- | Process a single predicate in a @deriving@ clause.
--
-- This returns a 'Maybe' because the user might try to derive 'Typeable',
-- which is a no-op nowadays.
derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar]
-> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec)
derivePred tc tys mb_lderiv_strat via_tvs deriv_pred =
-- We carefully set up uses of recoverM to minimize error message
-- cascades. See Note [Recovering from failures in deriving clauses].
recoverM (pure Nothing) $
setSrcSpan (getLocA deriv_pred) $ do
traceTc "derivePred" $ vcat
[ text "tc" <+> ppr tc
, text "tys" <+> ppr tys
, text "deriv_pred" <+> ppr deriv_pred
, text "mb_lderiv_strat" <+> ppr mb_lderiv_strat
, text "via_tvs" <+> ppr via_tvs ]
(cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred
when (cls_arg_kinds `lengthIsNot` 1) $
failWithTc (TcRnNonUnaryTypeclassConstraint deriv_pred)
let [cls_arg_kind] = cls_arg_kinds
mb_deriv_strat = fmap unLoc mb_lderiv_strat
if (className cls == typeableClassName)
then do warnUselessTypeable
return Nothing
else let deriv_tvs = via_tvs ++ cls_tvs in
Just <$> deriveTyData tc tys mb_deriv_strat
deriv_tvs cls cls_tys cls_arg_kind
{-
Note [Don't typecheck too much in DerivingVia]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following example:
data D = ...
deriving (A1 t, ..., A20 t) via T t
GHC used to be engineered such that it would typecheck the `deriving`
clause like so:
1. Take the first class in the clause (`A1`).
2. Typecheck the `via` type (`T t`) and bring its bound type variables
into scope (`t`).
3. Typecheck the class (`A1`).
4. Move on to the next class (`A2`) and repeat the process until all
classes have been typechecked.
This algorithm gets the job done most of the time, but it has two notable
flaws. One flaw is that it is wasteful: it requires that `T t` be typechecked
20 different times, once for each class in the `deriving` clause. This is
unnecessary because we only need to typecheck `T t` once in order to get
access to its bound type variable.
The other issue with this algorithm arises when there are no classes in the
`deriving` clause, like in the following example:
data D2 = ...
deriving () via Maybe Maybe
Because there are no classes, the algorithm above will simply do nothing.
As a consequence, GHC will completely miss the fact that `Maybe Maybe`
is ill-kinded nonsense (#16923).
To address both of these problems, GHC now uses this algorithm instead:
1. Typecheck the `via` type and bring its bound type variables into scope.
2. Take the first class in the `deriving` clause.
3. Typecheck the class.
4. Move on to the next class and repeat the process until all classes have been
typechecked.
This algorithm ensures that the `via` type is always typechecked, even if there
are no classes in the `deriving` clause. Moreover, it typecheck the `via` type
/exactly/ once and no more, even if there are multiple classes in the clause.
Note [Recovering from failures in deriving clauses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider what happens if you run this program (from #10684) without
DeriveGeneric enabled:
data A = A deriving (Show, Generic)
data B = B A deriving (Show)
Naturally, you'd expect GHC to give an error to the effect of:
Can't make a derived instance of `Generic A':
You need -XDeriveGeneric to derive an instance for this class
And *only* that error, since the other two derived Show instances appear to be
independent of this derived Generic instance. Yet GHC also used to give this
additional error on the program above:
No instance for (Show A)
arising from the 'deriving' clause of a data type declaration
When deriving the instance for (Show B)
This was happening because when GHC encountered any error within a single
data type's set of deriving clauses, it would call recoverM and move on
to the next data type's deriving clauses. One unfortunate consequence of
this design is that if A's derived Generic instance failed, its derived
Show instance would be skipped entirely, leading to the "No instance for
(Show A)" error cascade.
The solution to this problem is to push through uses of recoverM to the
level of the individual derived classes in a particular data type's set of
deriving clauses. That is, if you have:
newtype C = C D
deriving (E, F, G)
Then instead of processing instances E through M under the scope of a single
recoverM, as in the following pseudocode:
recoverM (pure Nothing) $ mapM derivePred [E, F, G]
We instead use recoverM in each iteration of the loop:
mapM (recoverM (pure Nothing) . derivePred) [E, F, G]
And then process each class individually, under its own recoverM scope. That
way, failure to derive one class doesn't cancel out other classes in the
same set of clause-derived classes.
-}
------------------------------------------------------------------
deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
-- Process a single standalone deriving declaration
-- e.g. deriving instance Show a => Show (T a)
-- Rather like tcLocalInstDecl
--
-- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays.
deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))
= setSrcSpanA loc $
addErrCtxt (standaloneCtxt deriv_ty) $
do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True
; traceTc "Deriving strategy (standalone deriving)" $
vcat [ppr mb_lderiv_strat, ppr deriv_ty]
; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat
; traceTc "Deriving strategy (standalone deriving) 2" $
vcat [ppr mb_lderiv_strat, ppr via_tvs]
; (cls_tvs, deriv_ctxt, cls, inst_tys)
<- tcExtendTyVarEnv via_tvs $
tcStandaloneDerivInstType ctxt deriv_ty
; let mb_deriv_strat = fmap unLoc mb_lderiv_strat
tvs = via_tvs ++ cls_tvs
-- See Note [Unify kinds in deriving]
; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <-
case mb_deriv_strat of
-- Perform an additional unification with the kind of the `via`
-- type and the result of the previous kind unification.
Just (ViaStrategy via_ty)
-- This unification must be performed on the last element of
-- inst_tys, but we have not yet checked for this property.
-- (This is done later in expectNonNullaryClsArgs). For now,
-- simply do nothing if inst_tys is empty, since
-- expectNonNullaryClsArgs will error later if this
-- is the case.
| Just inst_ty <- lastMaybe inst_tys
-> do
let via_kind = tcTypeKind via_ty
inst_ty_kind = tcTypeKind inst_ty
mb_match = tcUnifyTy inst_ty_kind via_kind
checkTc (isJust mb_match)
(TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $
DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)
let Just kind_subst = mb_match
ki_subst_range = getSubstRangeTyCoFVs kind_subst
-- See Note [Unification of two kind variables in deriving]
unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst
&& not (v `elemVarSet` ki_subst_range))
tvs
(subst, _) = substTyVarBndrs kind_subst unmapped_tkvs
(final_deriv_ctxt, final_deriv_ctxt_tys)
= case deriv_ctxt of
InferContext wc -> (InferContext wc, [])
SupplyContext theta ->
let final_theta = substTheta subst theta
in (SupplyContext final_theta, final_theta)
final_inst_tys = substTys subst inst_tys
final_via_ty = substTy subst via_ty
-- See Note [Floating `via` type variables]
final_tvs = tyCoVarsOfTypesWellScoped $
final_deriv_ctxt_tys ++ final_inst_tys
++ [final_via_ty]
pure ( final_tvs, final_deriv_ctxt, final_inst_tys
, Just (ViaStrategy final_via_ty) )
_ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat)
; traceTc "Standalone deriving;" $ vcat
[ text "tvs':" <+> ppr tvs'
, text "mb_deriv_strat':" <+> ppr mb_deriv_strat'
, text "deriv_ctxt':" <+> ppr deriv_ctxt'
, text "cls:" <+> ppr cls
, text "inst_tys':" <+> ppr inst_tys' ]
-- C.f. GHC.Tc.TyCl.Instance.tcLocalInstDecl1
; if className cls == typeableClassName
then do warnUselessTypeable
return Nothing
else Just <$> mkEqnHelp (fmap unLoc overlap_mode)
tvs' cls inst_tys'
deriv_ctxt' mb_deriv_strat' }
-- Typecheck the type in a standalone deriving declaration.
--
-- This may appear dense, but it's mostly huffing and puffing to recognize
-- the special case of a type with an extra-constraints wildcard context, e.g.,
--
-- deriving instance _ => Eq (Foo a)
--
-- If there is such a wildcard, we typecheck this as if we had written
-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,
-- as the 'DerivContext', where loc is the location of the wildcard used for
-- error reporting. This indicates that we should infer the context as if we
-- were deriving Eq via a deriving clause
-- (see Note [Inferring the instance context] in GHC.Tc.Deriv.Infer).
--
-- If there is no wildcard, then proceed as normal, and instead return
-- @'SupplyContext' theta@, where theta is the typechecked context.
--
-- Note that this will never return @'InferContext' 'Nothing'@, as that can
-- only happen with @deriving@ clauses.
tcStandaloneDerivInstType
:: UserTypeCtxt -> LHsSigWcType GhcRn
-> TcM ([TyVar], DerivContext, Class, [Type])
tcStandaloneDerivInstType ctxt
(HsWC { hswc_body = deriv_ty@(L loc (HsSig { sig_bndrs = outer_bndrs
, sig_body = deriv_ty_body }))})
| (theta, rho) <- splitLHsQualTy deriv_ty_body
, [wc_pred] <- fromMaybeContext theta
, L wc_span (HsWildCardTy _) <- ignoreParens wc_pred
= do dfun_ty <- tcHsClsInstType ctxt $ L loc $
HsSig { sig_ext = noExtField
, sig_bndrs = outer_bndrs
, sig_body = rho }
let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
pure (tvs, InferContext (Just (locA wc_span)), cls, inst_tys)
| otherwise
= do dfun_ty <- tcHsClsInstType ctxt deriv_ty
let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
pure (tvs, SupplyContext theta, cls, inst_tys)
warnUselessTypeable :: TcM ()
warnUselessTypeable = addDiagnosticTc TcRnUselessTypeable
------------------------------------------------------------------
deriveTyData :: TyCon -> [Type] -- LHS of data or data instance
-- Can be a data instance, hence [Type] args
-- and in that case the TyCon is the /family/ tycon
-> Maybe (DerivStrategy GhcTc) -- The optional deriving strategy
-> [TyVar] -- The type variables bound by the derived class
-> Class -- The derived class
-> [Type] -- The derived class's arguments
-> Kind -- The function argument in the derived class's kind.
-- (e.g., if `deriving Functor`, this would be
-- `Type -> Type` since
-- `Functor :: (Type -> Type) -> Constraint`)
-> TcM EarlyDerivSpec
-- The deriving clause of a data or newtype declaration
-- I.e. not standalone deriving
deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind
= do { -- Given data T a b c = ... deriving( C d ),
-- we want to drop type variables from T so that (C d (T a)) is well-kinded
let (arg_kinds, _) = splitFunTys cls_arg_kind
n_args_to_drop = length arg_kinds
n_args_to_keep = length tc_args - n_args_to_drop
-- See Note [tc_args and tycon arity]
(tc_args_to_keep, args_to_drop)
= splitAt n_args_to_keep tc_args
inst_ty_kind = tcTypeKind (mkTyConApp tc tc_args_to_keep)
-- Match up the kinds, and apply the resulting kind substitution
-- to the types. See Note [Unify kinds in deriving]
-- We are assuming the tycon tyvars and the class tyvars are distinct
mb_match = tcUnifyTy inst_ty_kind cls_arg_kind
enough_args = n_args_to_keep >= 0
-- Check that the result really is well-kinded
; checkTc (enough_args && isJust mb_match)
(TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $
DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep)
; let -- Returns a singleton-element list if using ViaStrategy and an
-- empty list otherwise. Useful for free-variable calculations.
deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type]
deriv_strat_tys = foldMap (foldDerivStrategy [] (:[]))
propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat'
= (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat)
where
ki_subst_range = getSubstRangeTyCoFVs kind_subst
-- See Note [Unification of two kind variables in deriving]
unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst
&& not (v `elemVarSet` ki_subst_range))
tkvs'
(subst, _) = substTyVarBndrs kind_subst unmapped_tkvs
final_tc_args = substTys subst tc_args'
final_cls_tys = substTys subst cls_tys'
final_mb_deriv_strat = fmap (mapDerivStrategy (substTy subst))
mb_deriv_strat'
-- See Note [Floating `via` type variables]
final_tkvs = tyCoVarsOfTypesWellScoped $
final_cls_tys ++ final_tc_args
++ deriv_strat_tys final_mb_deriv_strat
; let tkvs = scopedSort $ fvVarList $
unionFV (tyCoFVsOfTypes tc_args_to_keep)
(FV.mkFVs deriv_tvs)
Just kind_subst = mb_match
(tkvs', cls_tys', tc_args', mb_deriv_strat')
= propagate_subst kind_subst tkvs cls_tys
tc_args_to_keep mb_deriv_strat
-- See Note [Unify kinds in deriving]
; (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <-
case mb_deriv_strat' of
-- Perform an additional unification with the kind of the `via`
-- type and the result of the previous kind unification.
Just (ViaStrategy via_ty) -> do
let via_kind = tcTypeKind via_ty
inst_ty_kind
= tcTypeKind (mkTyConApp tc tc_args')
via_match = tcUnifyTy inst_ty_kind via_kind
checkTc (isJust via_match)
(TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $
DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)
let Just via_subst = via_match
pure $ propagate_subst via_subst tkvs' cls_tys'
tc_args' mb_deriv_strat'
_ -> pure (tkvs', cls_tys', tc_args', mb_deriv_strat')
; traceTc "deriveTyData 1" $ vcat
[ ppr final_mb_deriv_strat, pprTyVars deriv_tvs, ppr tc, ppr tc_args
, pprTyVars (tyCoVarsOfTypesList tc_args)
, ppr n_args_to_keep, ppr n_args_to_drop
, ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
, ppr final_tc_args, ppr final_cls_tys ]
; traceTc "deriveTyData 2" $ vcat
[ ppr final_tkvs ]
; let final_tc_app = mkTyConApp tc final_tc_args
final_cls_args = final_cls_tys ++ [final_tc_app]
; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c)
(TcRnCannotDeriveInstance cls final_cls_tys Nothing NoGeneralizedNewtypeDeriving $
DerivErrNoEtaReduce final_tc_app)
-- Check that
-- (a) The args to drop are all type variables; eg reject:
-- data instance T a Int = .... deriving( Monad )
-- (b) The args to drop are all *distinct* type variables; eg reject:
-- class C (a :: * -> * -> *) where ...
-- data instance T a a = ... deriving( C )
-- (c) The type class args, or remaining tycon args,
-- do not mention any of the dropped type variables
-- newtype T a s = ... deriving( ST s )
-- newtype instance K a a = ... deriving( Monad )
--
-- It is vital that the implementation of allDistinctTyVars
-- expand any type synonyms.
-- See Note [Eta-reducing type synonyms]
; checkValidInstHead DerivClauseCtxt cls final_cls_args
-- Check that we aren't deriving an instance of a magical
-- type like (~) or Coercible (#14916).
; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args
(InferContext Nothing) final_mb_deriv_strat
; traceTc "deriveTyData 3" (ppr spec)
; return spec }
{- Note [tc_args and tycon arity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
You might wonder if we could use (tyConArity tc) at this point, rather
than (length tc_args). But for data families the two can differ! The
tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which
in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them
from DataFamInstTyCon:
| DataFamInstTyCon -- See Note [Data type families]
(CoAxiom Unbranched)
TyCon -- The family TyCon
[Type] -- Argument types (mentions the tyConTyVars of this TyCon)
-- No shorter in length than the tyConTyVars of the family TyCon
-- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv
Notice that the arg tys might not be the same as the family tycon arity
(= length tyConTyVars).
Note [Unify kinds in deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (#8534)
data T a b = MkT a deriving( Functor )
-- where Functor :: (*->*) -> Constraint
So T :: forall k. * -> k -> *. We want to get
instance Functor (T * (a:*)) where ...
Notice the '*' argument to T.
Moreover, as well as instantiating T's kind arguments, we may need to instantiate
C's kind args. Consider (#8865):
newtype T a b = MkT (Either a b) deriving( Category )
where
Category :: forall k. (k -> k -> *) -> Constraint
We need to generate the instance
instance Category * (Either a) where ...
Notice the '*' argument to Category.
So we need to
* drop arguments from (T a b) to match the number of
arrows in the (last argument of the) class;
* and then *unify* kind of the remaining type against the
expected kind, to figure out how to instantiate C's and T's
kind arguments.
In the two examples,
* we unify kind-of( T k (a:k) ) ~ kind-of( Functor )
i.e. (k -> *) ~ (* -> *) to find k:=*.
yielding k:=*
* we unify kind-of( Either ) ~ kind-of( Category )
i.e. (* -> * -> *) ~ (k -> k -> k)
yielding k:=*
Now we get a kind substitution. We then need to:
1. Remove the substituted-out kind variables from the quantified kind vars
2. Apply the substitution to the kinds of quantified *type* vars
(and extend the substitution to reflect this change)
3. Apply that extended substitution to the non-dropped args (types and
kinds) of the type and class
Forgetting step (2) caused #8893:
data V a = V [a] deriving Functor
data P (x::k->*) (a:k) = P (x a) deriving Functor
data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor
When deriving Functor for P, we unify k to *, but we then want
an instance $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))
and similarly for C. Notice the modified kind of x, both at binding
and occurrence sites.
This can lead to some surprising results when *visible* kind binder is
unified (in contrast to the above examples, in which only non-visible kind
binders were considered). Consider this example from #11732:
data T k (a :: k) = MkT deriving Functor
Since unification yields k:=*, this results in a generated instance of:
instance Functor (T *) where ...
which looks odd at first glance, since one might expect the instance head
to be of the form Functor (T k). Indeed, one could envision an alternative
generated instance of:
instance (k ~ *) => Functor (T k) where
But this does not typecheck by design: kind equalities are not allowed to be
bound in types, only terms. But in essence, the two instance declarations are
entirely equivalent, since even though (T k) matches any kind k, the only
possibly value for k is *, since anything else is ill-typed. As a result, we can
just as comfortably use (T *).
Another way of thinking about is: deriving clauses often infer constraints.
For example:
data S a = S a deriving Eq
infers an (Eq a) constraint in the derived instance. By analogy, when we
are deriving Functor, we might infer an equality constraint (e.g., k ~ *).
The only distinction is that GHC instantiates equality constraints directly
during the deriving process.
Another quirk of this design choice manifests when typeclasses have visible
kind parameters. Consider this code (also from #11732):
class Cat k (cat :: k -> k -> *) where
catId :: cat a a
catComp :: cat b c -> cat a b -> cat a c
instance Cat * (->) where
catId = id
catComp = (.)
newtype Fun a b = Fun (a -> b) deriving (Cat k)
Even though we requested a derived instance of the form (Cat k Fun), the
kind unification will actually generate (Cat * Fun) (i.e., the same thing as if
the user wrote deriving (Cat *)).
What happens with DerivingVia, when you have yet another type? Consider:
newtype Foo (a :: Type) = MkFoo (Proxy a)
deriving Functor via Proxy
As before, we unify the kind of Foo (* -> *) with the kind of the argument to
Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind
(k -> *), which is more general than what we want. So we must additionally
unify (k -> *) with (* -> *).
Currently, all of this unification is implemented kludgily with the pure
unifier, which is rather tiresome. #14331 lays out a plan for how this
might be made cleaner.
Note [Unification of two kind variables in deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As a special case of the Note above, it is possible to derive an instance of
a poly-kinded typeclass for a poly-kinded datatype. For example:
class Category (cat :: k -> k -> *) where
newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category
This case is surprisingly tricky. To see why, let's write out what instance GHC
will attempt to derive (using -fprint-explicit-kinds syntax):
instance Category k1 (T k2 c) where ...
GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)
that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to
the type variable binder for c, since its kind is (k2 -> k2 -> *).
We used to accomplish this by doing the following:
unmapped_tkvs = filter (`notElemSubst` kind_subst) all_tkvs
(subst, _) = substTyVarBndrs kind_subst unmapped_tkvs
Where all_tkvs contains all kind variables in the class and instance types (in
this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,
this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped
to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].
This is bad, because applying that substitution yields the following instance:
instance Category k_new (T k1 c) where ...
In other words, keeping k1 in unmapped_tvks taints the substitution, resulting
in an ill-kinded instance (this caused #11837).
To prevent this, we need to filter out any variable from all_tkvs which either
1. Appears in the domain of kind_subst. notElemSubst checks this.
2. Appears in the range of kind_subst. To do this, we compute the free
variable set of the range of kind_subst with getSubstRangeTyCoFVs, and check
if a kind variable appears in that set.
Note [Eta-reducing type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One can instantiate a type in a data family instance with a type synonym that
mentions other type variables:
type Const a b = a
data family Fam (f :: * -> *) (a :: *)
newtype instance Fam f (Const a f) = Fam (f a) deriving Functor
It is also possible to define kind synonyms, and they can mention other types in
a datatype declaration. For example,
type Const a b = a
newtype T f (a :: Const * f) = T (f a) deriving Functor
When deriving, we need to perform eta-reduction analysis to ensure that none of
the eta-reduced type variables are mentioned elsewhere in the declaration. But
we need to be careful, because if we don't expand through the Const type
synonym, we will mistakenly believe that f is an eta-reduced type variable and
fail to derive Functor, even though the code above is correct (see #11416,
where this was first noticed). For this reason, we expand the type synonyms in
the eta-reduced types before doing any analysis.
Note [Floating `via` type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When generating a derived instance, it will be of the form:
instance forall ???. C c_args (D d_args) where ...
To fill in ???, GHC computes the free variables of `c_args` and `d_args`.
`DerivingVia` adds an extra wrinkle to this formula, since we must also
include the variables bound by the `via` type when computing the binders
used to fill in ???. This might seem strange, since if a `via` type binds
any type variables, then in almost all scenarios it will appear free in
`c_args` or `d_args`. There are certain corner cases where this does not hold,
however, such as in the following example (adapted from #15831):
newtype Age = MkAge Int
deriving Eq via Const Int a
In this example, the `via` type binds the type variable `a`, but `a` appears
nowhere in `Eq Age`. Nevertheless, we include it in the generated instance:
instance forall a. Eq Age where
(==) = coerce @(Const Int a -> Const Int a -> Bool)
@(Age -> Age -> Bool)
(==)
The use of `forall a` is certainly required here, since the `a` in
`Const Int a` would not be in scope otherwise. This instance is somewhat
strange in that nothing in the instance head `Eq Age` ever determines what `a`
will be, so any code that uses this instance will invariably instantiate `a`
to be `Any`. We refer to this property of `a` as being a "floating" `via`
type variable. Programs with floating `via` type variables are the only known
class of program in which the `via` type quantifies type variables that aren't
mentioned in the instance head in the generated instance.
Fortunately, the choice to instantiate floating `via` type variables to `Any`
is one that is completely transparent to the user (since the instance will
work as expected regardless of what `a` is instantiated to), so we decide to
permit them. An alternative design would make programs with floating `via`
variables illegal, by requiring that every variable mentioned in the `via` type
is also mentioned in the data header or the derived class. That restriction
would require the user to pick a particular type (the choice does not matter);
for example:
newtype Age = MkAge Int
-- deriving Eq via Const Int a -- Floating 'a'
deriving Eq via Const Int () -- Choose a=()
deriving Eq via Const Int Any -- Choose a=Any
No expressiveness would be lost thereby, but stylistically it seems preferable
to allow a type variable to indicate "it doesn't matter".
Note that by quantifying the `a` in `forall a. Eq Age`, we are deferring the
work of instantiating `a` to `Any` at every use site of the instance. An
alternative approach would be to generate an instance that directly defaulted
to `Any`:
instance Eq Age where
(==) = coerce @(Const Int Any -> Const Int Any -> Bool)
@(Age -> Age -> Bool)
(==)
We do not implement this approach since it would require a nontrivial amount
of implementation effort to substitute `Any` for the floating `via` type
variables, and since the end result isn't distinguishable from the former
instance (at least from the user's perspective), the amount of engineering
required to obtain the latter instance just isn't worth it.
-}
mkEqnHelp :: Maybe OverlapMode
-> [TyVar]
-> Class -> [Type]
-> DerivContext
-- SupplyContext => context supplied (standalone deriving)
-- InferContext => context inferred (deriving on data decl, or
-- standalone deriving decl with a wildcard)
-> Maybe (DerivStrategy GhcTc)
-> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
-- forall tvs. theta => cls (tys ++ [ty])
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded
mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do
is_boot <- tcIsHsBootOrSig
when is_boot $ bale_out DerivErrBootFileFound
let pred = mkClassPred cls cls_args
skol_info <- mkSkolemInfo (DerivSkol pred)
(tvs', cls_args', deriv_strat') <-
skolemise_when_inferring_context skol_info deriv_ctxt
let deriv_env = DerivEnv
{ denv_overlap_mode = overlap_mode
, denv_tvs = tvs'
, denv_cls = cls
, denv_inst_tys = cls_args'
, denv_ctxt = deriv_ctxt
, denv_skol_info = skol_info
, denv_strat = deriv_strat' }
runReaderT mk_eqn deriv_env
where
skolemise_when_inferring_context ::
SkolemInfo -> DerivContext
-> TcM ([TcTyVar], [TcType], Maybe (DerivStrategy GhcTc))
skolemise_when_inferring_context skol_info deriv_ctxt =
case deriv_ctxt of
-- In order to infer an instance context, we must later make use of
-- the constraint solving machinery, which expects TcTyVars rather
-- than TyVars. We skolemise the type variables with non-overlappable
-- (vanilla) skolems.
-- See Note [Overlap and deriving] in GHC.Tc.Deriv.Infer.
InferContext{} -> do
(skol_subst, tvs') <- tcInstSkolTyVars skol_info tvs
let cls_args' = substTys skol_subst cls_args
deriv_strat' = fmap (mapDerivStrategy (substTy skol_subst))
deriv_strat
pure (tvs', cls_args', deriv_strat')
-- If the instance context is supplied, we don't need to skolemise
-- at all.
SupplyContext{} -> pure (tvs, cls_args, deriv_strat)
bale_out =
failWithTc . TcRnCannotDeriveInstance cls cls_args deriv_strat NoGeneralizedNewtypeDeriving
mk_eqn :: DerivM EarlyDerivSpec
mk_eqn = do
DerivEnv { denv_inst_tys = cls_args
, denv_strat = mb_strat } <- ask
case mb_strat of
Just (StockStrategy _) -> do
(cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args
dit <- expectAlgTyConApp cls_tys inst_ty
mk_eqn_stock dit
Just (AnyclassStrategy _) -> mk_eqn_anyclass
Just (ViaStrategy via_ty) -> do
(cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args
mk_eqn_via cls_tys inst_ty via_ty
Just (NewtypeStrategy _) -> do
(cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args
dit <- expectAlgTyConApp cls_tys inst_ty
unless (isNewTyCon (dit_rep_tc dit)) $
derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrGNDUsedOnData
mkNewTypeEqn True dit
Nothing -> mk_eqn_no_strategy
-- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty.
-- If so, return @(init inst_tys, last inst_tys)@.
-- Otherwise, throw an error message.
-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this
-- property is important.
expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type)
expectNonNullaryClsArgs inst_tys =
maybe (derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrNullaryClasses) pure $
snocView inst_tys
-- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application
-- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting
-- of @cls_tys@ and the constituent pars of @inst_ty@.
-- Otherwise, throw an error message.
-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this
-- property is important.
expectAlgTyConApp :: [Type] -- All but the last argument to the class in a
-- derived instance
-> Type -- The last argument to the class in a
-- derived instance
-> DerivM DerivInstTys
expectAlgTyConApp cls_tys inst_ty = do
fam_envs <- lift tcGetFamInstEnvs
case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of
Nothing -> derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrLastArgMustBeApp
Just dit -> do expectNonDataFamTyCon dit
pure dit
-- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation
-- type constructor for a data family instance, and if not,
-- throws an error message.
-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this
-- property is important.
expectNonDataFamTyCon :: DerivInstTys -> DerivM ()
expectNonDataFamTyCon (DerivInstTys { dit_tc = tc
, dit_tc_args = tc_args
, dit_rep_tc = rep_tc }) =
-- If it's still a data family, the lookup failed; i.e no instance exists
when (isDataFamilyTyCon rep_tc) $
derivingThingFailWith NoGeneralizedNewtypeDeriving $
DerivErrNoFamilyInstance tc tc_args
mk_deriv_inst_tys_maybe :: FamInstEnvs
-> [Type] -> Type -> Maybe DerivInstTys
mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty =
fmap lookup $ tcSplitTyConApp_maybe inst_ty
where
lookup :: (TyCon, [Type]) -> DerivInstTys
lookup (tc, tc_args) =
-- Find the instance of a data family
-- Note [Looking up family instances for deriving]
let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args
dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args
in DerivInstTys { dit_cls_tys = cls_tys
, dit_tc = tc
, dit_tc_args = tc_args
, dit_rep_tc = rep_tc
, dit_rep_tc_args = rep_tc_args
, dit_dc_inst_arg_env = dc_inst_arg_env }
{-
Note [Looking up family instances for deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tcLookupFamInstExact is an auxiliary lookup wrapper which requires
that looked-up family instances exist. If called with a vanilla
tycon, the old type application is simply returned.
If we have
data instance F () = ... deriving Eq
data instance F () = ... deriving Eq
then tcLookupFamInstExact will be confused by the two matches;
but that can't happen because tcInstDecls1 doesn't call tcDeriving
if there are any overlaps.
There are two other things that might go wrong with the lookup.
First, we might see a standalone deriving clause
deriving Eq (F ())
when there is no data instance F () in scope.
Note that it's OK to have
data instance F [a] = ...
deriving Eq (F [(a,b)])
where the match is not exact; the same holds for ordinary data types
with standalone deriving declarations.
Note [Deriving, type families, and partial applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When there are no type families, it's quite easy:
newtype S a = MkS [a]
-- :CoS :: S ~ [] -- Eta-reduced
instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S
When type families are involved it's trickier:
data family T a b
newtype instance T Int a = MkT [a] deriving( Eq, Monad )
-- :RT is the representation type for (T Int a)
-- :Co:RT :: :RT ~ [] -- Eta-reduced!
-- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced!
instance Eq [a] => Eq (T Int a) -- easy by coercion
-- d1 :: Eq [a]
-- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))
instance Monad [] => Monad (T Int) -- only if we can eta reduce???
-- d1 :: Monad []
-- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
Note the need for the eta-reduced rule axioms. After all, we can
write it out
instance Monad [] => Monad (T Int) -- only if we can eta reduce???
return x = MkT [x]
... etc ...
See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
%************************************************************************
%* *
Deriving data types
* *
************************************************************************
-}
-- Once the DerivSpecMechanism is known, we can finally produce an
-- EarlyDerivSpec from it.
mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec
mk_eqn_from_mechanism mechanism
= do DerivEnv { denv_overlap_mode = overlap_mode
, denv_tvs = tvs
, denv_cls = cls
, denv_inst_tys = inst_tys
, denv_ctxt = deriv_ctxt
, denv_skol_info = skol_info } <- ask
user_ctxt <- askDerivUserTypeCtxt
doDerivInstErrorChecks1 mechanism
loc <- lift getSrcSpanM
dfun_name <- lift $ newDFunName cls inst_tys loc
case deriv_ctxt of
InferContext wildcard ->
do { (inferred_constraints, tvs', inst_tys', mechanism')
<- inferConstraints mechanism
; return $ InferTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs'
, ds_cls = cls, ds_tys = inst_tys'
, ds_theta = inferred_constraints
, ds_skol_info = skol_info
, ds_user_ctxt = user_ctxt
, ds_overlap = overlap_mode
, ds_standalone_wildcard = wildcard
, ds_mechanism = mechanism' } }
SupplyContext theta ->
return $ GivenTheta $ DS
{ ds_loc = loc
, ds_name = dfun_name, ds_tvs = tvs
, ds_cls = cls, ds_tys = inst_tys
, ds_theta = theta
, ds_skol_info = skol_info
, ds_user_ctxt = user_ctxt
, ds_overlap = overlap_mode
, ds_standalone_wildcard = Nothing
, ds_mechanism = mechanism }
mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class
-> DerivM EarlyDerivSpec
mk_eqn_stock dit
= do dflags <- getDynFlags
let isDeriveAnyClassEnabled =
deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)
checkOriginativeSideConditions dit >>= \case
CanDeriveStock gen_fns -> mk_eqn_from_mechanism $
DerivSpecStock { dsm_stock_dit = dit
, dsm_stock_gen_fns = gen_fns }
StockClassError why -> derivingThingFailWith NoGeneralizedNewtypeDeriving why
CanDeriveAnyClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving
(DerivErrNotStockDeriveable isDeriveAnyClassEnabled)
-- In the 'NonDerivableClass' case we can't derive with either stock or anyclass
-- so we /don't want/ to suggest the user to enabled 'DeriveAnyClass', that's
-- why we pass 'YesDeriveAnyClassEnabled', so that GHC won't attempt to suggest it.
NonDerivableClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving
(DerivErrNotStockDeriveable YesDeriveAnyClassEnabled)
mk_eqn_anyclass :: DerivM EarlyDerivSpec
mk_eqn_anyclass
= do dflags <- getDynFlags
let isDeriveAnyClassEnabled =
deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)
case xopt LangExt.DeriveAnyClass dflags of
True -> mk_eqn_from_mechanism DerivSpecAnyClass
False -> derivingThingFailWith NoGeneralizedNewtypeDeriving
(DerivErrNotDeriveable isDeriveAnyClassEnabled)
mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class
-> Type -- The newtype's representation type
-> DerivM EarlyDerivSpec
mk_eqn_newtype dit rep_ty =
mk_eqn_from_mechanism $ DerivSpecNewtype { dsm_newtype_dit = dit
, dsm_newtype_rep_ty = rep_ty }
mk_eqn_via :: [Type] -- All arguments to the class besides the last
-> Type -- The last argument to the class
-> Type -- The @via@ type
-> DerivM EarlyDerivSpec
mk_eqn_via cls_tys inst_ty via_ty =
mk_eqn_from_mechanism $ DerivSpecVia { dsm_via_cls_tys = cls_tys
, dsm_via_inst_ty = inst_ty
, dsm_via_ty = via_ty }
-- Derive an instance without a user-requested deriving strategy. This uses
-- heuristics to determine which deriving strategy to use.
-- See Note [Deriving strategies].
mk_eqn_no_strategy :: DerivM EarlyDerivSpec
mk_eqn_no_strategy = do
DerivEnv { denv_cls = cls
, denv_inst_tys = cls_args } <- ask
fam_envs <- lift tcGetFamInstEnvs
-- First, check if the last argument is an application of a type constructor.
-- If not, fall back to DeriveAnyClass.
if | Just (cls_tys, inst_ty) <- snocView cls_args
, Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty
-> if | isNewTyCon (dit_rep_tc dit)
-- We have a dedicated code path for newtypes (see the
-- documentation for mkNewTypeEqn as to why this is the case)
-> mkNewTypeEqn False dit
| otherwise
-> do -- Otherwise, our only other options are stock or anyclass.
-- If it is stock, we must confirm that the last argument's
-- type constructor is algebraic.
-- See Note [DerivEnv and DerivSpecMechanism] in GHC.Tc.Deriv.Utils
whenIsJust (hasStockDeriving cls) $ \_ ->
expectNonDataFamTyCon dit
mk_eqn_originative dit
| otherwise
-> mk_eqn_anyclass
where
-- Use heuristics (checkOriginativeSideConditions) to determine whether
-- stock or anyclass deriving should be used.
mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec
mk_eqn_originative dit@(DerivInstTys { dit_tc = tc
, dit_rep_tc = rep_tc }) = do
dflags <- getDynFlags
let isDeriveAnyClassEnabled =
deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)
-- See Note [Deriving instances for classes themselves]
let dac_error
| isClassTyCon rep_tc
= DerivErrOnlyAnyClassDeriveable tc isDeriveAnyClassEnabled
| otherwise
= DerivErrNotStockDeriveable isDeriveAnyClassEnabled
checkOriginativeSideConditions dit >>= \case
NonDerivableClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving dac_error
StockClassError why -> derivingThingFailWith NoGeneralizedNewtypeDeriving why
CanDeriveStock gen_fns -> mk_eqn_from_mechanism $
DerivSpecStock { dsm_stock_dit = dit
, dsm_stock_gen_fns = gen_fns }
CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass
{-
************************************************************************
* *
Deriving instances for newtypes
* *
************************************************************************
-}
-- Derive an instance for a newtype. We put this logic into its own function
-- because
--
-- (a) When no explicit deriving strategy is requested, we have special
-- heuristics for newtypes to determine which deriving strategy should
-- actually be used. See Note [Deriving strategies].
-- (b) We make an effort to give error messages specifically tailored to
-- newtypes.
mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@
-- deriving strategy?
-> DerivInstTys -> DerivM EarlyDerivSpec
mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys
, dit_rep_tc = rep_tycon
, dit_rep_tc_args = rep_tc_args })
-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
= do DerivEnv{denv_cls = cls} <- ask
dflags <- getDynFlags
let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags
deriveAnyClass = xopt LangExt.DeriveAnyClass dflags
bale_out = derivingThingFailWith (usingGeneralizedNewtypeDeriving newtype_deriving)
-- Here is the plan for newtype derivings. We see
-- newtype T a1...an = MkT (t ak+1...an)
-- deriving (.., C s1 .. sm, ...)
-- where t is a type,
-- ak+1...an is a suffix of a1..an, and are all tyvars
-- ak+1...an do not occur free in t, nor in the s1..sm
-- (C s1 ... sm) is a *partial applications* of class C
-- with the last parameter missing
-- (T a1 .. ak) matches the kind of C's last argument
-- (and hence so does t)
-- The latter kind-check has been done by deriveTyData already,
-- and tc_args are already trimmed
--
-- We generate the instance
-- instance forall ({a1..ak} u fvs(s1..sm)).
-- C s1 .. sm t => C s1 .. sm (T a1...ak)
-- where T a1...ap is the partial application of
-- the LHS of the correct kind and p >= k
--
-- NB: the variables below are:
-- tc_tvs = [a1, ..., an]
-- tyvars_to_keep = [a1, ..., ak]
-- rep_ty = t ak .. an
-- deriv_tvs = fvs(s1..sm) \ tc_tvs
-- tys = [s1, ..., sm]
-- rep_fn' = t
--
-- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
-- We generate the instance
-- instance Monad (ST s) => Monad (T s) where
nt_eta_arity = newTyConEtadArity rep_tycon
-- For newtype T a b = MkT (S a a b), the TyCon
-- machinery already eta-reduces the representation type, so
-- we know that
-- T a ~ S a a
-- That's convenient here, because we may have to apply
-- it to fewer than its original complement of arguments
-- Note [Newtype representation]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Need newTyConRhs (*not* a recursive representation finder)
-- to get the representation type. For example
-- newtype B = MkB Int
-- newtype A = MkA B deriving( Num )
-- We want the Num instance of B, *not* the Num instance of Int,
-- when making the Num instance of A!
rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
-------------------------------------------------------------------
-- Figuring out whether we can only do this newtype-deriving thing
-- See Note [Determining whether newtype-deriving is appropriate]
might_be_newtype_derivable
= not (non_coercible_class cls)
&& eta_ok
-- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes]
-- Check that eta reduction is OK
eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity
-- The newtype can be eta-reduced to match the number
-- of type argument actually supplied
-- newtype T a b = MkT (S [a] b) deriving( Monad )
-- Here the 'b' must be the same in the rep type (S [a] b)
-- And the [a] must not mention 'b'. That's all handled
-- by nt_eta_rity.
massert (cls_tys `lengthIs` (classArity cls - 1))
if newtype_strat
then
-- Since the user explicitly asked for GeneralizedNewtypeDeriving,
-- we don't need to perform all of the checks we normally would,
-- such as if the class being derived is known to produce ill-roled
-- coercions (e.g., Traversable), since we can just derive the
-- instance and let it error if need be.
-- See Note [Determining whether newtype-deriving is appropriate]
if eta_ok && newtype_deriving
then mk_eqn_newtype dit rep_inst_ty
else bale_out (DerivErrCannotEtaReduceEnough eta_ok)
else
if might_be_newtype_derivable
&& ((newtype_deriving && not deriveAnyClass)
|| std_class_via_coercible cls)
then mk_eqn_newtype dit rep_inst_ty
else checkOriginativeSideConditions dit >>= \case
StockClassError why
-- There's a particular corner case where
--
-- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are
-- both enabled at the same time
-- 2. We're deriving a particular stock derivable class
-- (such as Functor)
--
-- and the previous cases won't catch it. This fixes the bug
-- reported in #10598.
| might_be_newtype_derivable && newtype_deriving
-> mk_eqn_newtype dit rep_inst_ty
-- Otherwise, throw an error for a stock class
| might_be_newtype_derivable && not newtype_deriving
-> bale_out why
| otherwise
-> bale_out why
-- Must use newtype deriving or DeriveAnyClass
NonDerivableClass
-- Too hard, even with newtype deriving
| newtype_deriving -> bale_out (DerivErrCannotEtaReduceEnough eta_ok)
-- Try newtype deriving!
-- Here we suggest GeneralizedNewtypeDeriving even in cases
-- where it may not be applicable. See #9600.
| otherwise -> bale_out DerivErrNewtypeNonDeriveableClass
-- DeriveAnyClass
CanDeriveAnyClass -> do
-- If both DeriveAnyClass and GeneralizedNewtypeDeriving are
-- enabled, we take the diplomatic approach of defaulting to
-- DeriveAnyClass, but emitting a warning about the choice.
-- See Note [Deriving strategies]
when (newtype_deriving && deriveAnyClass) $
lift $ addDiagnosticTc
$ TcRnDerivingDefaults cls
mk_eqn_from_mechanism DerivSpecAnyClass
-- CanDeriveStock
CanDeriveStock gen_fns -> mk_eqn_from_mechanism $
DerivSpecStock { dsm_stock_dit = dit
, dsm_stock_gen_fns = gen_fns }
{-
Note [Recursive newtypes]
~~~~~~~~~~~~~~~~~~~~~~~~~
Newtype deriving works fine, even if the newtype is recursive.
e.g. newtype S1 = S1 [T1 ()]
newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
Remember, too, that type families are currently (conservatively) given
a recursive flag, so this also allows newtype deriving to work
for type families.
We used to exclude recursive types, because we had a rather simple
minded way of generating the instance decl:
newtype A = MkA [A]
instance Eq [A] => Eq A -- Makes typechecker loop!
But now we require a simple context, so it's ok.
Note [Determining whether newtype-deriving is appropriate]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we see
newtype NT = MkNT Foo
deriving C
we have to decide how to perform the deriving. Do we do newtype deriving,
or do we do normal deriving? In general, we prefer to do newtype deriving
wherever possible. So, we try newtype deriving unless there's a glaring
reason not to.
"Glaring reasons not to" include trying to derive a class for which a
coercion-based instance doesn't make sense. These classes are listed in
the definition of non_coercible_class. They include Show (since it must
show the name of the datatype) and Traversable (since a coercion-based
Traversable instance is ill-roled).
However, non_coercible_class is ignored if the user explicitly requests
to derive an instance with GeneralizedNewtypeDeriving using the newtype
deriving strategy. In such a scenario, GHC will unquestioningly try to
derive the instance via coercions (even if the final generated code is
ill-roled!). See Note [Deriving strategies].
Note that newtype deriving might fail, even after we commit to it. This
is because the derived instance uses `coerce`, which must satisfy its
`Coercible` constraint. This is different than other deriving scenarios,
where we're sure that the resulting instance will type-check.
Note [GND and associated type families]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for
classes with associated type families. A general recipe is:
class C x y z where
type T y z x
op :: x -> [y] -> z
newtype N a = MkN <rep-type> deriving( C )
=====>
instance C x y <rep-type> => C x y (N a) where
type T y (N a) x = T y <rep-type> x
op = coerce (op :: x -> [y] -> <rep-type>)
However, we must watch out for three things:
(a) The class must not contain any data families. If it did, we'd have to
generate a fresh data constructor name for the derived data family
instance, and it's not clear how to do this.
(b) Each associated type family's type variables must mention the last type
variable of the class. As an example, you wouldn't be able to use GND to
derive an instance of this class:
class C a b where
type T a
But you would be able to derive an instance of this class:
class C a b where
type T b
The difference is that in the latter T mentions the last parameter of C
(i.e., it mentions b), but the former T does not. If you tried, e.g.,
newtype Foo x = Foo x deriving (C a)
with the former definition of C, you'd end up with something like this:
instance C a (Foo x) where
type T a = T ???
This T family instance doesn't mention the newtype (or its representation
type) at all, so we disallow such constructions with GND.
(c) UndecidableInstances might need to be enabled. Here's a case where it is
most definitely necessary:
class C a where
type T a
newtype Loop = Loop MkLoop deriving C
=====>
instance C Loop where
type T Loop = T Loop
Obviously, T Loop would send the typechecker into a loop. Unfortunately,
you might even need UndecidableInstances even in cases where the
typechecker would be guaranteed to terminate. For example:
instance C Int where
type C Int = Int
newtype MyInt = MyInt Int deriving C
=====>
instance C MyInt where
type T MyInt = T Int
GHC's termination checker isn't sophisticated enough to conclude that the
definition of T MyInt terminates, so UndecidableInstances is required.
(d) For the time being, we do not allow the last type variable of the class to
appear in a /kind/ of an associated type family definition. For instance:
class C a where
type T1 a -- OK
type T2 (x :: a) -- Illegal: a appears in the kind of x
type T3 y :: a -- Illegal: a appears in the kind of (T3 y)
The reason we disallow this is because our current approach to deriving
associated type family instances—i.e., by unwrapping the newtype's type
constructor as shown above—is ill-equipped to handle the scenario when
the last type variable appears as an implicit argument. In the worst case,
allowing the last variable to appear in a kind can result in improper Core
being generated (see #14728).
There is hope for this feature being added some day, as one could
conceivably take a newtype axiom (which witnesses a coercion between a
newtype and its representation type) at lift that through each associated
type at the Core level. See #14728, comment:3 for a sketch of how this
might work. Until then, we disallow this featurette wholesale.
The same criteria apply to DerivingVia.
************************************************************************
* *
Bindings for the various classes
* *
************************************************************************
After all the trouble to figure out the required context for the
derived instance declarations, all that's left is to chug along to
produce them. They will then be shoved into @tcInstDecls2@, which
will do all its usual business.
There are lots of possibilities for code to generate. Here are
various general remarks.
PRINCIPLES:
\begin{itemize}
\item
We want derived instances of @Eq@ and @Ord@ (both v common) to be
``you-couldn't-do-better-by-hand'' efficient.
\item
Deriving @Show@---also pretty common--- should also be reasonable good code.
\item
Deriving for the other classes isn't that common or that big a deal.
\end{itemize}
PRAGMATICS:
\begin{itemize}
\item
Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
\item
Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
\item
We {\em normally} generate code only for the non-defaulted methods;
there are some exceptions for @Eq@ and (especially) @Ord@...
\item
Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
constructor's numeric (@Int#@) tag. These are generated by
@gen_tag_n_con_binds@, and the heuristic for deciding if one of
these is around is given by @hasCon2TagFun@.
The examples under the different sections below will make this
clearer.
\item
Much less often (really just for deriving @Ix@), we use a
@_tag2con_<tycon>@ function. See the examples.
\item
We use the renamer!!! Reason: we're supposed to be
producing @LHsBinds Name@ for the methods, but that means
producing correctly-uniquified code on the fly. This is entirely
possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
So, instead, we produce @MonoBinds RdrName@ then heave 'em through
the renamer. What a great hack!
\end{itemize}
-}
-- | Generate the 'InstInfo' for the required instance,
-- plus any auxiliary bindings required (see @Note [Auxiliary binders]@ in
-- "GHC.Tc.Deriv.Generate") and any additional free variables
-- that should be marked (see @Note [Deriving and unused record selectors]@
-- in "GHC.Tc.Deriv.Utils").
genInstBinds :: DerivSpec ThetaType
-> TcM (InstInfo GhcPs, Bag AuxBindSpec, [Name])
genInstBinds spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism
, ds_tys = inst_tys, ds_theta = theta, ds_cls = clas
, ds_loc = loc, ds_standalone_wildcard = wildcard })
= set_spec_span_and_ctxt spec $
do (meth_binds, meth_sigs, aux_specs, unusedNames) <- gen_inst_binds
inst_spec <- newDerivClsInst spec
doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism
traceTc "newder" (ppr inst_spec)
let inst_info =
InstInfo
{ iSpec = inst_spec
, iBinds = InstBindings
{ ib_binds = meth_binds
, ib_tyvars = map Var.varName tyvars
, ib_pragmas = meth_sigs
, ib_extensions = extensions
, ib_derived = True } }
return (inst_info, aux_specs, unusedNames)
where
extensions :: [LangExt.Extension]
extensions
| isDerivSpecNewtype mechanism || isDerivSpecVia mechanism
= [
-- Both these flags are needed for higher-rank uses of coerce...
LangExt.ImpredicativeTypes, LangExt.RankNTypes
-- ...and this flag is needed to support the instance signatures
-- that bring type variables into scope.
-- See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate
, LangExt.InstanceSigs
-- Skip unboxed tuples checking for derived instances when imported
-- in a different module, see #20524
, LangExt.UnboxedTuples
]
| otherwise
= []
gen_inst_binds :: TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
gen_inst_binds
= case mechanism of
-- See Note [Bindings for Generalised Newtype Deriving]
DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}
-> gen_newtype_or_via rhs_ty
-- Try a stock deriver
DerivSpecStock { dsm_stock_dit = dit
, dsm_stock_gen_fns =
StockGenFns { stock_gen_binds = gen_fn } }
-> gen_fn loc dit
-- Try DeriveAnyClass
DerivSpecAnyClass
-> return (emptyBag, [], emptyBag, [])
-- No method bindings, signatures, auxiliary bindings or free
-- variable names are needed. The only interesting work happens when
-- defaulting associated type family instances (see the
-- DeriveSpecAnyClass case in genFamInsts below).
-- Try DerivingVia
DerivSpecVia{dsm_via_ty = via_ty}
-> gen_newtype_or_via via_ty
gen_newtype_or_via ty = do
let (binds, sigs) = gen_Newtype_binds loc clas tyvars inst_tys ty
return (binds, sigs, emptyBag, [])
-- | Generate the associated type family instances for a derived instance.
genFamInsts :: DerivSpec theta -> TcM [FamInst]
genFamInsts spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism
, ds_tys = inst_tys, ds_cls = clas, ds_loc = loc })
= set_spec_span_and_ctxt spec $
case mechanism of
-- See Note [GND and associated type families]
DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}
-> gen_newtype_or_via rhs_ty
-- Try a stock deriver
DerivSpecStock { dsm_stock_dit = dit
, dsm_stock_gen_fns =
StockGenFns { stock_gen_fam_insts = gen_fn } }
-> gen_fn loc dit
-- See Note [DeriveAnyClass and default family instances]
DerivSpecAnyClass -> do
let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
mini_subst = mkTvSubst (mkInScopeSetList tyvars) mini_env
dflags <- getDynFlags
tyfam_insts <-
-- canDeriveAnyClass should ensure that this code can't be reached
-- unless -XDeriveAnyClass is enabled.
assertPpr (xopt LangExt.DeriveAnyClass dflags)
(text "genFamInsts: bad derived class" <+> ppr clas) $
mapM (tcATDefault loc mini_subst emptyNameSet)
(classATItems clas)
pure $ concat tyfam_insts
-- Try DerivingVia
DerivSpecVia{dsm_via_ty = via_ty}
-> gen_newtype_or_via via_ty
where
gen_newtype_or_via ty = gen_Newtype_fam_insts loc clas tyvars inst_tys ty
-- Set the SrcSpan and error context for an action that uses a DerivSpec.
set_spec_span_and_ctxt :: DerivSpec theta -> TcM a -> TcM a
set_spec_span_and_ctxt (DS{ ds_loc = loc, ds_cls = clas, ds_tys = tys }) =
setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)
-- Checks:
--
-- * All of the data constructors for a data type are in scope for a
-- standalone-derived instance (for `stock` and `newtype` deriving).
--
-- * All of the associated type families of a class are suitable for
-- GeneralizedNewtypeDeriving or DerivingVia (for `newtype` and `via`
-- deriving).
doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
doDerivInstErrorChecks1 mechanism =
case mechanism of
DerivSpecStock{dsm_stock_dit = dit}
-> data_cons_in_scope_check dit
DerivSpecNewtype{dsm_newtype_dit = dit}
-> do atf_coerce_based_error_checks
data_cons_in_scope_check dit
DerivSpecAnyClass{}
-> pure ()
DerivSpecVia{}
-> atf_coerce_based_error_checks
where
-- When processing a standalone deriving declaration, check that all of the
-- constructors for the data type are in scope. For instance:
--
-- import M (T)
-- deriving stock instance Eq T
--
-- This should be rejected, as the derived Eq instance would need to refer
-- to the constructors for T, which are not in scope.
--
-- Note that the only strategies that require this check are `stock` and
-- `newtype`. Neither `anyclass` nor `via` require it as the code that they
-- generate does not require using data constructors.
data_cons_in_scope_check :: DerivInstTys -> DerivM ()
data_cons_in_scope_check (DerivInstTys { dit_tc = tc
, dit_rep_tc = rep_tc }) = do
standalone <- isStandaloneDeriv
when standalone $ do
let bale_out msg = do err <- derivingThingErrMechanism mechanism msg
lift $ failWithTc err
rdr_env <- lift getGlobalRdrEnv
let data_con_names = map dataConName (tyConDataCons rep_tc)
hidden_data_cons = not (isWiredIn rep_tc) &&
(isAbstractTyCon rep_tc ||
any not_in_scope data_con_names)
not_in_scope dc = isNothing (lookupGRE_Name rdr_env dc)
-- Make sure to also mark the data constructors as used so that GHC won't
-- mistakenly emit -Wunused-imports warnings about them.
lift $ addUsedDataCons rdr_env rep_tc
unless (not hidden_data_cons) $
bale_out $ DerivErrDataConsNotAllInScope tc
-- Ensure that a class's associated type variables are suitable for
-- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is
-- only required for the `newtype` and `via` strategies.
--
-- See Note [GND and associated type families]
atf_coerce_based_error_checks :: DerivM ()
atf_coerce_based_error_checks = do
cls <- asks denv_cls
let bale_out msg = do err <- derivingThingErrMechanism mechanism msg
lift $ failWithTc err
cls_tyvars = classTyVars cls
ats_look_sensible
= -- Check (a) from Note [GND and associated type families]
no_adfs
-- Check (b) from Note [GND and associated type families]
&& isNothing at_without_last_cls_tv
-- Check (d) from Note [GND and associated type families]
&& isNothing at_last_cls_tv_in_kinds
(adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs
no_adfs = null adf_tcs
-- We cannot newtype-derive data family instances
at_without_last_cls_tv
= find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs
at_last_cls_tv_in_kinds
= find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind)
(tyConTyVars tc)
|| at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs
at_last_cls_tv_in_kind kind
= last_cls_tv `elemVarSet` exactTyCoVarsOfType kind
at_tcs = classATs cls
last_cls_tv = assert (notNull cls_tyvars )
last cls_tyvars
unless ats_look_sensible $
bale_out (DerivErrHasAssociatedDatatypes
(hasAssociatedDataFamInsts (not no_adfs))
(associatedTyLastVarInKind at_last_cls_tv_in_kinds)
(associatedTyNotParamOverLastTyVar at_without_last_cls_tv)
)
doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
-> DerivSpecMechanism -> TcM ()
doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism
= do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)
; dflags <- getDynFlags
; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures
; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures
-- Error if PartialTypeSignatures isn't enabled when a user tries
-- to write @deriving instance _ => Eq (Foo a)@. Or, if that
-- extension is enabled, give a warning if -Wpartial-type-signatures
-- is enabled.
; case wildcard of
Nothing -> pure ()
Just span -> setSrcSpan span $ do
let suggParSigs = suggestPartialTypeSignatures xpartial_sigs
let dia = TcRnPartialTypeSignatures suggParSigs theta
checkTc xpartial_sigs dia
diagnosticTc wpartial_sigs dia
-- Check for Generic instances that are derived with an exotic
-- deriving strategy like DAC
-- See Note [Deriving strategies]
; when (exotic_mechanism && className clas `elem` genericClassNames) $
do { failIfTc (safeLanguageOn dflags)
(TcRnCannotDeriveInstance clas mempty Nothing NoGeneralizedNewtypeDeriving $
DerivErrSafeHaskellGenericInst)
; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } }
where
exotic_mechanism = not $ isDerivSpecStock mechanism
derivingThingFailWith :: UsingGeneralizedNewtypeDeriving
-- ^ If 'YesGeneralizedNewtypeDeriving', add a snippet about
-- how not even GeneralizedNewtypeDeriving would make this
-- declaration work. This only kicks in when
-- an explicit deriving strategy is not given.
-> DeriveInstanceErrReason -- The reason the derivation failed
-> DerivM a
derivingThingFailWith newtype_deriving msg = do
err <- derivingThingErrM newtype_deriving msg
lift $ failWithTc err
{-
Note [Bindings for Generalised Newtype Deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
class Eq a => C a where
f :: a -> a
newtype N a = MkN [a] deriving( C )
instance Eq (N a) where ...
The 'deriving C' clause generates, in effect
instance (C [a], Eq a) => C (N a) where
f = coerce (f :: [a] -> [a])
This generates a cast for each method, but allows the superclasses to
be worked out in the usual way. In this case the superclass (Eq (N
a)) will be solved by the explicit Eq (N a) instance. We do *not*
create the superclasses by casting the superclass dictionaries for the
representation type.
See the paper "Safe zero-cost coercions for Haskell".
Note [DeriveAnyClass and default family instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When a class has a associated type family with a default instance, e.g.:
class C a where
type T a
type T a = Char
then there are a couple of scenarios in which a user would expect T a to
default to Char. One is when an instance declaration for C is given without
an implementation for T:
instance C Int
Another scenario in which this can occur is when the -XDeriveAnyClass extension
is used:
data Example = Example deriving (C, Generic)
In the latter case, we must take care to check if C has any associated type
families with default instances, because -XDeriveAnyClass will never provide
an implementation for them. We "fill in" the default instances using the
tcATDefault function from GHC.Tc.TyCl.Class (which is also used in GHC.Tc.TyCl.Instance to
handle the empty instance declaration case).
Note [Deriving strategies]
~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC has a notion of deriving strategies, which allow the user to explicitly
request which approach to use when deriving an instance (enabled with the
-XDerivingStrategies language extension). For more information, refer to the
original issue (#10598) or the associated wiki page:
https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies
A deriving strategy can be specified in a deriving clause:
newtype Foo = MkFoo Bar
deriving newtype C
Or in a standalone deriving declaration:
deriving anyclass instance C Foo
-XDerivingStrategies also allows the use of multiple deriving clauses per data
declaration so that a user can derive some instance with one deriving strategy
and other instances with another deriving strategy. For example:
newtype Baz = Baz Quux
deriving (Eq, Ord)
deriving stock (Read, Show)
deriving newtype (Num, Floating)
deriving anyclass C
Currently, the deriving strategies are:
* stock: Have GHC implement a "standard" instance for a data type, if possible
(e.g., Eq, Ord, Generic, Data, Functor, etc.)
* anyclass: Use -XDeriveAnyClass
* newtype: Use -XGeneralizedNewtypeDeriving
* via: Use -XDerivingVia
The latter two strategies (newtype and via) are referred to as the
"coerce-based" strategies, since they generate code that relies on the `coerce`
function. See, for instance, GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased.
The former two strategies (stock and anyclass), in contrast, are
referred to as the "originative" strategies, since they create "original"
instances instead of "reusing" old instances (by way of `coerce`).
See, for instance, GHC.Tc.Deriv.Utils.checkOriginativeSideConditions.
If an explicit deriving strategy is not given, GHC has an algorithm it uses to
determine which strategy it will actually use. The algorithm is quite long,
so it lives in the Haskell wiki at
https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies
("The deriving strategy resolution algorithm" section).
Internally, GHC uses the DerivStrategy datatype to denote a user-requested
deriving strategy, and it uses the DerivSpecMechanism datatype to denote what
GHC will use to derive the instance after taking the above steps. In other
words, GHC will always settle on a DerivSpecMechnism, even if the user did not
ask for a particular DerivStrategy (using the algorithm linked to above).
Note [Deriving instances for classes themselves]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Much of the code in GHC.Tc.Deriv assumes that deriving only works on data types.
But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly
reasonable to do something like this:
{-# LANGUAGE DeriveAnyClass #-}
class C1 (a :: Constraint) where
class C2 where
deriving instance C1 C2
-- This is equivalent to `instance C1 C2`
If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock
deriving), we throw a special error message indicating that DeriveAnyClass is
the only way to go. We don't bother throwing this error if an explicit 'stock'
or 'newtype' keyword is used, since both options have their own perfectly
sensible error messages in the case of the above code (as C1 isn't a stock
derivable class, and C2 isn't a newtype).
************************************************************************
* *
What con2tag/tag2con functions are available?
* *
************************************************************************
-}
derivingThingErrM :: UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> DerivM TcRnMessage
derivingThingErrM newtype_deriving why
= do DerivEnv { denv_cls = cls
, denv_inst_tys = cls_args
, denv_strat = mb_strat } <- ask
pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why
derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
derivingThingErrMechanism mechanism why
= do DerivEnv { denv_cls = cls
, denv_inst_tys = cls_args
, denv_strat = mb_strat } <- ask
pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why
where
newtype_deriving :: UsingGeneralizedNewtypeDeriving
newtype_deriving
= if isDerivSpecNewtype mechanism then YesGeneralizedNewtypeDeriving
else NoGeneralizedNewtypeDeriving
standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
2 (quotes (ppr ty))
|