The unpac monorepo manager self-hosting as a monorepo using unpac
error messages: replace Format by Format_doc
+1154
-955
+193
-15
.depend
+193
-15
.depend
···
81
81
utils/misc.cmi
82
82
utils/diffing.cmo : \
83
83
utils/misc.cmi \
84
+
utils/format_doc.cmi \
84
85
utils/diffing.cmi
85
86
utils/diffing.cmx : \
86
87
utils/misc.cmx \
88
+
utils/format_doc.cmx \
87
89
utils/diffing.cmi
88
90
utils/diffing.cmi : \
89
-
utils/misc.cmi
91
+
utils/misc.cmi \
92
+
utils/format_doc.cmi
90
93
utils/diffing_with_keys.cmo : \
91
94
utils/misc.cmi \
95
+
utils/format_doc.cmi \
92
96
utils/diffing.cmi \
93
97
utils/diffing_with_keys.cmi
94
98
utils/diffing_with_keys.cmx : \
95
99
utils/misc.cmx \
100
+
utils/format_doc.cmx \
96
101
utils/diffing.cmx \
97
102
utils/diffing_with_keys.cmi
98
103
utils/diffing_with_keys.cmi : \
104
+
utils/format_doc.cmi \
99
105
utils/diffing.cmi
100
106
utils/domainstate.cmo : \
101
107
utils/domainstate.cmi
102
108
utils/domainstate.cmx : \
103
109
utils/domainstate.cmi
104
110
utils/domainstate.cmi :
111
+
utils/format_doc.cmo : \
112
+
utils/format_doc.cmi
113
+
utils/format_doc.cmx : \
114
+
utils/format_doc.cmi
115
+
utils/format_doc.cmi :
105
116
utils/identifiable.cmo : \
106
117
utils/misc.cmi \
107
118
utils/identifiable.cmi
···
121
132
utils/lazy_backtrack.cmi :
122
133
utils/linkdeps.cmo : \
123
134
utils/misc.cmi \
135
+
utils/format_doc.cmi \
124
136
utils/linkdeps.cmi
125
137
utils/linkdeps.cmx : \
126
138
utils/misc.cmx \
139
+
utils/format_doc.cmx \
127
140
utils/linkdeps.cmi
128
-
utils/linkdeps.cmi :
141
+
utils/linkdeps.cmi : \
142
+
utils/format_doc.cmi
129
143
utils/load_path.cmo : \
130
144
utils/misc.cmi \
131
145
utils/local_store.cmi \
···
143
157
utils/local_store.cmi
144
158
utils/local_store.cmi :
145
159
utils/misc.cmo : \
160
+
utils/format_doc.cmi \
146
161
utils/config.cmi \
147
162
utils/build_path_prefix_map.cmi \
148
163
utils/misc.cmi
149
164
utils/misc.cmx : \
165
+
utils/format_doc.cmx \
150
166
utils/config.cmx \
151
167
utils/build_path_prefix_map.cmx \
152
168
utils/misc.cmi
153
169
utils/misc.cmi : \
170
+
utils/format_doc.cmi \
154
171
utils/build_path_prefix_map.cmi
155
172
utils/numbers.cmo : \
156
173
utils/misc.cmi \
···
195
212
utils/terminfo.cmi :
196
213
utils/warnings.cmo : \
197
214
utils/misc.cmi \
215
+
utils/format_doc.cmi \
198
216
utils/warnings.cmi
199
217
utils/warnings.cmx : \
200
218
utils/misc.cmx \
219
+
utils/format_doc.cmx \
201
220
utils/warnings.cmi
202
-
utils/warnings.cmi :
221
+
utils/warnings.cmi : \
222
+
utils/format_doc.cmi
203
223
parsing/ast_helper.cmo : \
204
224
parsing/syntaxerr.cmi \
205
225
parsing/parsetree.cmi \
···
259
279
parsing/longident.cmi \
260
280
parsing/location.cmi \
261
281
utils/load_path.cmi \
282
+
utils/format_doc.cmi \
262
283
utils/config.cmi \
263
284
utils/clflags.cmi \
264
285
parsing/asttypes.cmi \
···
270
291
parsing/longident.cmx \
271
292
parsing/location.cmx \
272
293
utils/load_path.cmx \
294
+
utils/format_doc.cmx \
273
295
utils/config.cmx \
274
296
utils/clflags.cmx \
275
297
parsing/asttypes.cmx \
···
290
312
parsing/parsetree.cmi \
291
313
utils/misc.cmi \
292
314
parsing/location.cmi \
315
+
utils/format_doc.cmi \
293
316
parsing/builtin_attributes.cmi \
294
317
parsing/asttypes.cmi \
295
318
parsing/attr_helper.cmi
···
297
320
parsing/parsetree.cmi \
298
321
utils/misc.cmx \
299
322
parsing/location.cmx \
323
+
utils/format_doc.cmx \
300
324
parsing/builtin_attributes.cmx \
301
325
parsing/asttypes.cmx \
302
326
parsing/attr_helper.cmi
303
327
parsing/attr_helper.cmi : \
304
328
parsing/parsetree.cmi \
305
329
parsing/location.cmi \
330
+
utils/format_doc.cmi \
306
331
parsing/asttypes.cmi
307
332
parsing/builtin_attributes.cmo : \
308
333
utils/warnings.cmi \
···
310
335
utils/misc.cmi \
311
336
parsing/longident.cmi \
312
337
parsing/location.cmi \
338
+
utils/format_doc.cmi \
313
339
utils/clflags.cmi \
314
340
parsing/asttypes.cmi \
315
341
parsing/ast_iterator.cmi \
···
321
347
utils/misc.cmx \
322
348
parsing/longident.cmx \
323
349
parsing/location.cmx \
350
+
utils/format_doc.cmx \
324
351
utils/clflags.cmx \
325
352
parsing/asttypes.cmx \
326
353
parsing/ast_iterator.cmx \
···
375
402
parsing/parser.cmi \
376
403
utils/misc.cmi \
377
404
parsing/location.cmi \
405
+
utils/format_doc.cmi \
378
406
parsing/docstrings.cmi \
379
407
parsing/lexer.cmi
380
408
parsing/lexer.cmx : \
···
382
410
parsing/parser.cmx \
383
411
utils/misc.cmx \
384
412
parsing/location.cmx \
413
+
utils/format_doc.cmx \
385
414
parsing/docstrings.cmx \
386
415
parsing/lexer.cmi
387
416
parsing/lexer.cmi : \
···
391
420
utils/warnings.cmi \
392
421
utils/terminfo.cmi \
393
422
utils/misc.cmi \
423
+
utils/format_doc.cmi \
394
424
utils/clflags.cmi \
395
425
utils/build_path_prefix_map.cmi \
396
426
parsing/location.cmi
···
398
428
utils/warnings.cmx \
399
429
utils/terminfo.cmx \
400
430
utils/misc.cmx \
431
+
utils/format_doc.cmx \
401
432
utils/clflags.cmx \
402
433
utils/build_path_prefix_map.cmx \
403
434
parsing/location.cmi
404
435
parsing/location.cmi : \
405
-
utils/warnings.cmi
436
+
utils/warnings.cmi \
437
+
utils/format_doc.cmi
406
438
parsing/longident.cmo : \
407
439
utils/misc.cmi \
408
440
parsing/longident.cmi
···
417
449
utils/misc.cmi \
418
450
parsing/location.cmi \
419
451
parsing/lexer.cmi \
452
+
utils/format_doc.cmi \
420
453
parsing/docstrings.cmi \
421
454
parsing/parse.cmi
422
455
parsing/parse.cmx : \
···
426
459
utils/misc.cmx \
427
460
parsing/location.cmx \
428
461
parsing/lexer.cmx \
462
+
utils/format_doc.cmx \
429
463
parsing/docstrings.cmx \
430
464
parsing/parse.cmi
431
465
parsing/parse.cmi : \
···
470
504
parsing/longident.cmi \
471
505
parsing/location.cmi \
472
506
parsing/lexer.cmi \
507
+
utils/format_doc.cmi \
473
508
parsing/asttypes.cmi \
474
509
parsing/pprintast.cmi
475
510
parsing/pprintast.cmx : \
···
477
512
parsing/longident.cmx \
478
513
parsing/location.cmx \
479
514
parsing/lexer.cmx \
515
+
utils/format_doc.cmx \
480
516
parsing/asttypes.cmx \
481
517
parsing/pprintast.cmi
482
518
parsing/pprintast.cmi : \
483
519
parsing/parsetree.cmi \
484
-
parsing/longident.cmi
520
+
parsing/longident.cmi \
521
+
utils/format_doc.cmi
485
522
parsing/printast.cmo : \
486
523
parsing/pprintast.cmi \
487
524
parsing/parsetree.cmi \
···
586
623
parsing/location.cmi \
587
624
utils/local_store.cmi \
588
625
typing/ident.cmi \
626
+
utils/format_doc.cmi \
589
627
typing/errortrace.cmi \
590
628
typing/env.cmi \
591
629
utils/clflags.cmi \
···
603
641
parsing/location.cmx \
604
642
utils/local_store.cmx \
605
643
typing/ident.cmx \
644
+
utils/format_doc.cmx \
606
645
typing/errortrace.cmx \
607
646
typing/env.cmx \
608
647
utils/clflags.cmx \
···
656
695
utils/load_path.cmi \
657
696
utils/lazy_backtrack.cmi \
658
697
typing/ident.cmi \
698
+
utils/format_doc.cmi \
659
699
typing/datarepr.cmi \
660
700
file_formats/cmi_format.cmi \
661
701
utils/clflags.cmi \
···
679
719
utils/load_path.cmx \
680
720
utils/lazy_backtrack.cmx \
681
721
typing/ident.cmx \
722
+
utils/format_doc.cmx \
682
723
typing/datarepr.cmx \
683
724
file_formats/cmi_format.cmx \
684
725
utils/clflags.cmx \
···
698
739
parsing/location.cmi \
699
740
utils/load_path.cmi \
700
741
typing/ident.cmi \
742
+
utils/format_doc.cmi \
701
743
file_formats/cmi_format.cmi \
702
744
parsing/asttypes.cmi
703
745
typing/envaux.cmo : \
···
707
749
utils/misc.cmi \
708
750
parsing/location.cmi \
709
751
typing/ident.cmi \
752
+
utils/format_doc.cmi \
710
753
typing/env.cmi \
711
754
parsing/asttypes.cmi \
712
755
typing/envaux.cmi
···
717
760
utils/misc.cmx \
718
761
parsing/location.cmx \
719
762
typing/ident.cmx \
763
+
utils/format_doc.cmx \
720
764
typing/env.cmx \
721
765
parsing/asttypes.cmx \
722
766
typing/envaux.cmi
723
767
typing/envaux.cmi : \
724
768
typing/subst.cmi \
725
769
typing/path.cmi \
770
+
utils/format_doc.cmi \
726
771
typing/env.cmi
727
772
typing/errortrace.cmo : \
728
773
typing/types.cmi \
729
774
typing/path.cmi \
775
+
utils/format_doc.cmi \
730
776
parsing/asttypes.cmi \
731
777
typing/errortrace.cmi
732
778
typing/errortrace.cmx : \
733
779
typing/types.cmx \
734
780
typing/path.cmx \
781
+
utils/format_doc.cmx \
735
782
parsing/asttypes.cmx \
736
783
typing/errortrace.cmi
737
784
typing/errortrace.cmi : \
738
785
typing/types.cmi \
739
786
typing/path.cmi \
787
+
utils/format_doc.cmi \
740
788
parsing/asttypes.cmi
741
789
typing/ident.cmo : \
742
790
utils/misc.cmi \
743
791
utils/local_store.cmi \
744
792
utils/identifiable.cmi \
793
+
utils/format_doc.cmi \
745
794
utils/clflags.cmi \
746
795
typing/ident.cmi
747
796
typing/ident.cmx : \
748
797
utils/misc.cmx \
749
798
utils/local_store.cmx \
750
799
utils/identifiable.cmx \
800
+
utils/format_doc.cmx \
751
801
utils/clflags.cmx \
752
802
typing/ident.cmi
753
803
typing/ident.cmi : \
754
-
utils/identifiable.cmi
804
+
utils/identifiable.cmi \
805
+
utils/format_doc.cmi
755
806
typing/includeclass.cmo : \
756
807
typing/types.cmi \
757
808
typing/printtyp.cmi \
758
809
typing/path.cmi \
759
810
utils/misc.cmi \
811
+
utils/format_doc.cmi \
760
812
typing/ctype.cmi \
761
813
parsing/builtin_attributes.cmi \
762
814
typing/includeclass.cmi
···
765
817
typing/printtyp.cmx \
766
818
typing/path.cmx \
767
819
utils/misc.cmx \
820
+
utils/format_doc.cmx \
768
821
typing/ctype.cmx \
769
822
parsing/builtin_attributes.cmx \
770
823
typing/includeclass.cmi
···
772
825
typing/types.cmi \
773
826
typing/printtyp.cmi \
774
827
parsing/location.cmi \
828
+
utils/format_doc.cmi \
775
829
typing/env.cmi \
776
830
typing/ctype.cmi
777
831
typing/includecore.cmo : \
···
783
837
typing/path.cmi \
784
838
utils/misc.cmi \
785
839
typing/ident.cmi \
840
+
utils/format_doc.cmi \
786
841
typing/errortrace.cmi \
787
842
typing/env.cmi \
788
843
utils/diffing_with_keys.cmi \
···
800
855
typing/path.cmx \
801
856
utils/misc.cmx \
802
857
typing/ident.cmx \
858
+
utils/format_doc.cmx \
803
859
typing/errortrace.cmx \
804
860
typing/env.cmx \
805
861
utils/diffing_with_keys.cmx \
···
815
871
typing/path.cmi \
816
872
parsing/location.cmi \
817
873
typing/ident.cmi \
874
+
utils/format_doc.cmi \
818
875
typing/errortrace.cmi \
819
876
typing/env.cmi \
820
877
utils/diffing_with_keys.cmi
···
891
948
typing/includecore.cmi \
892
949
typing/includeclass.cmi \
893
950
typing/ident.cmi \
951
+
utils/format_doc.cmi \
894
952
typing/env.cmi \
895
953
utils/diffing.cmi \
896
954
utils/clflags.cmi \
···
908
966
typing/includecore.cmx \
909
967
typing/includeclass.cmx \
910
968
typing/ident.cmx \
969
+
utils/format_doc.cmx \
911
970
typing/env.cmx \
912
971
utils/diffing.cmx \
913
972
utils/clflags.cmx \
···
916
975
typing/types.cmi \
917
976
typing/typedtree.cmi \
918
977
typing/includemod.cmi \
978
+
utils/format_doc.cmi \
919
979
typing/env.cmi
920
980
typing/mtype.cmo : \
921
981
typing/types.cmi \
···
950
1010
parsing/pprintast.cmi \
951
1011
typing/outcometree.cmi \
952
1012
parsing/lexer.cmi \
1013
+
utils/format_doc.cmi \
953
1014
parsing/asttypes.cmi \
954
1015
typing/oprint.cmi
955
1016
typing/oprint.cmx : \
956
1017
parsing/pprintast.cmx \
957
1018
typing/outcometree.cmi \
958
1019
parsing/lexer.cmx \
1020
+
utils/format_doc.cmx \
959
1021
parsing/asttypes.cmx \
960
1022
typing/oprint.cmi
961
1023
typing/oprint.cmi : \
962
-
typing/outcometree.cmi
1024
+
typing/outcometree.cmi \
1025
+
utils/format_doc.cmi
963
1026
typing/outcometree.cmi : \
964
1027
typing/type_immediacy.cmi \
1028
+
utils/format_doc.cmi \
965
1029
parsing/asttypes.cmi
966
1030
typing/parmatch.cmo : \
967
1031
utils/warnings.cmi \
···
978
1042
parsing/longident.cmi \
979
1043
parsing/location.cmi \
980
1044
typing/ident.cmi \
1045
+
utils/format_doc.cmi \
981
1046
typing/env.cmi \
982
1047
typing/ctype.cmi \
983
1048
typing/btype.cmi \
···
998
1063
parsing/longident.cmx \
999
1064
parsing/location.cmx \
1000
1065
typing/ident.cmx \
1066
+
utils/format_doc.cmx \
1001
1067
typing/env.cmx \
1002
1068
typing/ctype.cmx \
1003
1069
typing/btype.cmx \
···
1013
1079
typing/path.cmo : \
1014
1080
parsing/lexer.cmi \
1015
1081
typing/ident.cmi \
1082
+
utils/format_doc.cmi \
1016
1083
typing/path.cmi
1017
1084
typing/path.cmx : \
1018
1085
parsing/lexer.cmx \
1019
1086
typing/ident.cmx \
1087
+
utils/format_doc.cmx \
1020
1088
typing/path.cmi
1021
1089
typing/path.cmi : \
1022
-
typing/ident.cmi
1090
+
typing/ident.cmi \
1091
+
utils/format_doc.cmi
1023
1092
typing/patterns.cmo : \
1024
1093
typing/types.cmi \
1025
1094
typing/typedtree.cmi \
···
1053
1122
parsing/location.cmi \
1054
1123
utils/load_path.cmi \
1055
1124
utils/lazy_backtrack.cmi \
1125
+
utils/format_doc.cmi \
1056
1126
utils/consistbl.cmi \
1057
1127
file_formats/cmi_format.cmi \
1058
1128
utils/clflags.cmi \
···
1064
1134
parsing/location.cmx \
1065
1135
utils/load_path.cmx \
1066
1136
utils/lazy_backtrack.cmx \
1137
+
utils/format_doc.cmx \
1067
1138
utils/consistbl.cmx \
1068
1139
file_formats/cmi_format.cmx \
1069
1140
utils/clflags.cmx \
···
1075
1146
parsing/location.cmi \
1076
1147
utils/load_path.cmi \
1077
1148
utils/lazy_backtrack.cmi \
1149
+
utils/format_doc.cmi \
1078
1150
utils/consistbl.cmi \
1079
1151
file_formats/cmi_format.cmi
1080
1152
typing/predef.cmo : \
···
1108
1180
typing/outcometree.cmi \
1109
1181
utils/misc.cmi \
1110
1182
parsing/location.cmi \
1183
+
utils/format_doc.cmi \
1111
1184
parsing/attr_helper.cmi \
1112
1185
typing/primitive.cmi
1113
1186
typing/primitive.cmx : \
···
1115
1188
typing/outcometree.cmi \
1116
1189
utils/misc.cmx \
1117
1190
parsing/location.cmx \
1191
+
utils/format_doc.cmx \
1118
1192
parsing/attr_helper.cmx \
1119
1193
typing/primitive.cmi
1120
1194
typing/primitive.cmi : \
···
1125
1199
typing/types.cmi \
1126
1200
typing/typedtree.cmi \
1127
1201
typing/ident.cmi \
1202
+
utils/format_doc.cmi \
1128
1203
parsing/asttypes.cmi \
1129
1204
typing/printpat.cmi
1130
1205
typing/printpat.cmx : \
1131
1206
typing/types.cmx \
1132
1207
typing/typedtree.cmx \
1133
1208
typing/ident.cmx \
1209
+
utils/format_doc.cmx \
1134
1210
parsing/asttypes.cmx \
1135
1211
typing/printpat.cmi
1136
1212
typing/printpat.cmi : \
1137
1213
typing/typedtree.cmi \
1214
+
utils/format_doc.cmi \
1138
1215
parsing/asttypes.cmi
1139
1216
typing/printtyp.cmo : \
1140
1217
utils/warnings.cmi \
···
1154
1231
parsing/longident.cmi \
1155
1232
parsing/location.cmi \
1156
1233
typing/ident.cmi \
1234
+
utils/format_doc.cmi \
1157
1235
typing/errortrace.cmi \
1158
1236
typing/env.cmi \
1159
1237
typing/ctype.cmi \
···
1179
1257
parsing/longident.cmx \
1180
1258
parsing/location.cmx \
1181
1259
typing/ident.cmx \
1260
+
utils/format_doc.cmx \
1182
1261
typing/errortrace.cmx \
1183
1262
typing/env.cmx \
1184
1263
typing/ctype.cmx \
···
1194
1273
parsing/longident.cmi \
1195
1274
parsing/location.cmi \
1196
1275
typing/ident.cmi \
1276
+
utils/format_doc.cmi \
1197
1277
typing/errortrace.cmi \
1198
-
typing/env.cmi
1278
+
typing/env.cmi \
1279
+
parsing/asttypes.cmi
1199
1280
typing/printtyped.cmo : \
1200
1281
typing/types.cmi \
1201
1282
typing/typedtree.cmi \
···
1228
1309
typing/types.cmi \
1229
1310
parsing/pprintast.cmi \
1230
1311
typing/path.cmi \
1312
+
utils/format_doc.cmi \
1231
1313
parsing/asttypes.cmi \
1232
1314
typing/rawprinttyp.cmi
1233
1315
typing/rawprinttyp.cmx : \
1234
1316
typing/types.cmx \
1235
1317
parsing/pprintast.cmx \
1236
1318
typing/path.cmx \
1319
+
utils/format_doc.cmx \
1237
1320
parsing/asttypes.cmx \
1238
1321
typing/rawprinttyp.cmi
1239
1322
typing/rawprinttyp.cmi : \
···
1286
1369
typing/printtyp.cmi \
1287
1370
utils/misc.cmi \
1288
1371
parsing/location.cmi \
1372
+
utils/format_doc.cmi \
1289
1373
utils/clflags.cmi \
1290
1374
typing/annot.cmi \
1291
1375
typing/stypes.cmi
···
1294
1378
typing/printtyp.cmx \
1295
1379
utils/misc.cmx \
1296
1380
parsing/location.cmx \
1381
+
utils/format_doc.cmx \
1297
1382
utils/clflags.cmx \
1298
1383
typing/annot.cmi \
1299
1384
typing/stypes.cmi
···
1402
1487
parsing/location.cmi \
1403
1488
typing/includeclass.cmi \
1404
1489
typing/ident.cmi \
1490
+
utils/format_doc.cmi \
1405
1491
typing/errortrace.cmi \
1406
1492
typing/env.cmi \
1407
1493
typing/ctype.cmi \
···
1431
1517
parsing/location.cmx \
1432
1518
typing/includeclass.cmx \
1433
1519
typing/ident.cmx \
1520
+
utils/format_doc.cmx \
1434
1521
typing/errortrace.cmx \
1435
1522
typing/env.cmx \
1436
1523
typing/ctype.cmx \
···
1448
1535
parsing/longident.cmi \
1449
1536
parsing/location.cmi \
1450
1537
typing/ident.cmi \
1538
+
utils/format_doc.cmi \
1451
1539
typing/errortrace.cmi \
1452
1540
typing/env.cmi \
1453
1541
typing/ctype.cmi \
···
1466
1554
typing/printpat.cmi \
1467
1555
typing/primitive.cmi \
1468
1556
typing/predef.cmi \
1469
-
parsing/pprintast.cmi \
1470
1557
typing/persistent_env.cmi \
1471
1558
typing/path.cmi \
1472
1559
parsing/parsetree.cmi \
···
1476
1563
parsing/longident.cmi \
1477
1564
parsing/location.cmi \
1478
1565
typing/ident.cmi \
1566
+
utils/format_doc.cmi \
1479
1567
typing/errortrace.cmi \
1480
1568
typing/env.cmi \
1481
1569
typing/ctype.cmi \
···
1500
1588
typing/printpat.cmx \
1501
1589
typing/primitive.cmx \
1502
1590
typing/predef.cmx \
1503
-
parsing/pprintast.cmx \
1504
1591
typing/persistent_env.cmx \
1505
1592
typing/path.cmx \
1506
1593
parsing/parsetree.cmi \
···
1510
1597
parsing/longident.cmx \
1511
1598
parsing/location.cmx \
1512
1599
typing/ident.cmx \
1600
+
utils/format_doc.cmx \
1513
1601
typing/errortrace.cmx \
1514
1602
typing/env.cmx \
1515
1603
typing/ctype.cmx \
···
1558
1646
lambda/lambda.cmi \
1559
1647
typing/includecore.cmi \
1560
1648
typing/ident.cmi \
1649
+
utils/format_doc.cmi \
1561
1650
typing/errortrace.cmi \
1562
1651
typing/env.cmi \
1563
1652
typing/ctype.cmi \
···
1596
1685
lambda/lambda.cmx \
1597
1686
typing/includecore.cmx \
1598
1687
typing/ident.cmx \
1688
+
utils/format_doc.cmx \
1599
1689
typing/errortrace.cmx \
1600
1690
typing/env.cmx \
1601
1691
typing/ctype.cmx \
···
1621
1711
parsing/location.cmi \
1622
1712
typing/includecore.cmi \
1623
1713
typing/ident.cmi \
1714
+
utils/format_doc.cmi \
1624
1715
typing/errortrace.cmi \
1625
1716
typing/env.cmi \
1626
1717
parsing/asttypes.cmi
···
1743
1834
parsing/longident.cmi \
1744
1835
parsing/location.cmi \
1745
1836
typing/ident.cmi \
1837
+
utils/format_doc.cmi \
1746
1838
typing/env.cmi \
1747
1839
parsing/asttypes.cmi \
1748
1840
typing/typedtree.cmi
···
1756
1848
parsing/longident.cmx \
1757
1849
parsing/location.cmx \
1758
1850
typing/ident.cmx \
1851
+
utils/format_doc.cmx \
1759
1852
typing/env.cmx \
1760
1853
parsing/asttypes.cmx \
1761
1854
typing/typedtree.cmi
···
1769
1862
parsing/longident.cmi \
1770
1863
parsing/location.cmi \
1771
1864
typing/ident.cmi \
1865
+
utils/format_doc.cmi \
1772
1866
typing/env.cmi \
1773
1867
parsing/asttypes.cmi
1774
1868
typing/typemod.cmo : \
···
1797
1891
typing/includemod_errorprinter.cmi \
1798
1892
typing/includemod.cmi \
1799
1893
typing/ident.cmi \
1894
+
utils/format_doc.cmi \
1800
1895
typing/errortrace.cmi \
1801
1896
typing/env.cmi \
1802
1897
typing/ctype.cmi \
···
1835
1930
typing/includemod_errorprinter.cmx \
1836
1931
typing/includemod.cmx \
1837
1932
typing/ident.cmx \
1933
+
utils/format_doc.cmx \
1838
1934
typing/errortrace.cmx \
1839
1935
typing/env.cmx \
1840
1936
typing/ctype.cmx \
···
1947
2043
utils/misc.cmi \
1948
2044
parsing/longident.cmi \
1949
2045
parsing/location.cmi \
2046
+
utils/format_doc.cmi \
1950
2047
typing/errortrace.cmi \
1951
2048
typing/env.cmi \
1952
2049
typing/ctype.cmi \
···
1967
2064
utils/misc.cmx \
1968
2065
parsing/longident.cmx \
1969
2066
parsing/location.cmx \
2067
+
utils/format_doc.cmx \
1970
2068
typing/errortrace.cmx \
1971
2069
typing/env.cmx \
1972
2070
typing/ctype.cmx \
···
1982
2080
parsing/parsetree.cmi \
1983
2081
parsing/longident.cmi \
1984
2082
parsing/location.cmi \
2083
+
utils/format_doc.cmi \
1985
2084
typing/errortrace.cmi \
1986
2085
typing/env.cmi \
1987
2086
parsing/asttypes.cmi
···
2079
2178
parsing/location.cmi \
2080
2179
utils/load_path.cmi \
2081
2180
utils/linkdeps.cmi \
2181
+
utils/format_doc.cmi \
2082
2182
bytecomp/emitcode.cmi \
2083
2183
utils/config.cmi \
2084
2184
file_formats/cmo_format.cmi \
···
2090
2190
parsing/location.cmx \
2091
2191
utils/load_path.cmx \
2092
2192
utils/linkdeps.cmx \
2193
+
utils/format_doc.cmx \
2093
2194
bytecomp/emitcode.cmx \
2094
2195
utils/config.cmx \
2095
2196
file_formats/cmo_format.cmi \
···
2097
2198
bytecomp/bytelink.cmx \
2098
2199
bytecomp/bytelibrarian.cmi
2099
2200
bytecomp/bytelibrarian.cmi : \
2100
-
utils/linkdeps.cmi
2201
+
utils/linkdeps.cmi \
2202
+
utils/format_doc.cmi
2101
2203
bytecomp/bytelink.cmo : \
2102
2204
bytecomp/symtable.cmi \
2103
2205
bytecomp/opcodes.cmi \
···
2106
2208
utils/load_path.cmi \
2107
2209
utils/linkdeps.cmi \
2108
2210
bytecomp/instruct.cmi \
2211
+
utils/format_doc.cmi \
2109
2212
bytecomp/emitcode.cmi \
2110
2213
bytecomp/dll.cmi \
2111
2214
utils/consistbl.cmi \
···
2124
2227
utils/load_path.cmx \
2125
2228
utils/linkdeps.cmx \
2126
2229
bytecomp/instruct.cmx \
2230
+
utils/format_doc.cmx \
2127
2231
bytecomp/emitcode.cmx \
2128
2232
bytecomp/dll.cmx \
2129
2233
utils/consistbl.cmx \
···
2138
2242
bytecomp/symtable.cmi \
2139
2243
utils/misc.cmi \
2140
2244
utils/linkdeps.cmi \
2245
+
utils/format_doc.cmi \
2141
2246
file_formats/cmo_format.cmi
2142
2247
bytecomp/bytepackager.cmo : \
2143
2248
parsing/unit_info.cmi \
···
2153
2258
utils/load_path.cmi \
2154
2259
bytecomp/instruct.cmi \
2155
2260
typing/ident.cmi \
2261
+
utils/format_doc.cmi \
2156
2262
typing/env.cmi \
2157
2263
bytecomp/emitcode.cmi \
2158
2264
utils/config.cmi \
···
2176
2282
utils/load_path.cmx \
2177
2283
bytecomp/instruct.cmx \
2178
2284
typing/ident.cmx \
2285
+
utils/format_doc.cmx \
2179
2286
typing/env.cmx \
2180
2287
bytecomp/emitcode.cmx \
2181
2288
utils/config.cmx \
···
2186
2293
bytecomp/bytegen.cmx \
2187
2294
bytecomp/bytepackager.cmi
2188
2295
bytecomp/bytepackager.cmi : \
2296
+
utils/format_doc.cmi \
2189
2297
typing/env.cmi \
2190
2298
file_formats/cmo_format.cmi
2191
2299
bytecomp/bytesections.cmo : \
···
2217
2325
lambda/lambda.cmi \
2218
2326
bytecomp/instruct.cmi \
2219
2327
typing/ident.cmi \
2328
+
utils/format_doc.cmi \
2220
2329
typing/env.cmi \
2221
2330
utils/config.cmi \
2222
2331
utils/compression.cmi \
···
2237
2346
lambda/lambda.cmx \
2238
2347
bytecomp/instruct.cmx \
2239
2348
typing/ident.cmx \
2349
+
utils/format_doc.cmx \
2240
2350
typing/env.cmx \
2241
2351
utils/config.cmx \
2242
2352
utils/compression.cmx \
···
2312
2422
parsing/location.cmi \
2313
2423
lambda/lambda.cmi \
2314
2424
typing/ident.cmi \
2425
+
utils/format_doc.cmi \
2315
2426
bytecomp/dll.cmi \
2316
2427
utils/config.cmi \
2317
2428
file_formats/cmo_format.cmi \
···
2325
2436
parsing/location.cmx \
2326
2437
lambda/lambda.cmx \
2327
2438
typing/ident.cmx \
2439
+
utils/format_doc.cmx \
2328
2440
bytecomp/dll.cmx \
2329
2441
utils/config.cmx \
2330
2442
file_formats/cmo_format.cmi \
···
2333
2445
bytecomp/symtable.cmi : \
2334
2446
lambda/lambda.cmi \
2335
2447
typing/ident.cmi \
2448
+
utils/format_doc.cmi \
2336
2449
file_formats/cmo_format.cmi
2337
2450
asmcomp/CSE.cmo : \
2338
2451
asmcomp/mach.cmi \
···
2423
2536
asmcomp/interval.cmi \
2424
2537
asmcomp/interf.cmi \
2425
2538
typing/ident.cmi \
2539
+
utils/format_doc.cmi \
2426
2540
asmcomp/emitaux.cmi \
2427
2541
asmcomp/emit.cmi \
2428
2542
asmcomp/deadcode.cmi \
···
2467
2581
asmcomp/interval.cmx \
2468
2582
asmcomp/interf.cmx \
2469
2583
typing/ident.cmx \
2584
+
utils/format_doc.cmx \
2470
2585
asmcomp/emitaux.cmx \
2471
2586
asmcomp/emit.cmx \
2472
2587
asmcomp/deadcode.cmx \
···
2486
2601
asmcomp/asmgen.cmi : \
2487
2602
parsing/unit_info.cmi \
2488
2603
lambda/lambda.cmi \
2604
+
utils/format_doc.cmi \
2489
2605
asmcomp/emitaux.cmi \
2490
2606
asmcomp/cmm.cmi \
2491
2607
middle_end/clambda.cmi \
···
2495
2611
parsing/location.cmi \
2496
2612
utils/load_path.cmi \
2497
2613
utils/linkdeps.cmi \
2614
+
utils/format_doc.cmi \
2498
2615
middle_end/flambda/export_info.cmi \
2499
2616
utils/config.cmi \
2500
2617
middle_end/compilenv.cmi \
···
2509
2626
parsing/location.cmx \
2510
2627
utils/load_path.cmx \
2511
2628
utils/linkdeps.cmx \
2629
+
utils/format_doc.cmx \
2512
2630
middle_end/flambda/export_info.cmx \
2513
2631
utils/config.cmx \
2514
2632
middle_end/compilenv.cmx \
···
2519
2637
asmcomp/asmlink.cmx \
2520
2638
asmcomp/asmlibrarian.cmi
2521
2639
asmcomp/asmlibrarian.cmi : \
2522
-
utils/linkdeps.cmi
2640
+
utils/linkdeps.cmi \
2641
+
utils/format_doc.cmi
2523
2642
asmcomp/asmlink.cmo : \
2524
2643
asmcomp/thread_sanitizer.cmi \
2525
2644
lambda/runtimedef.cmi \
···
2528
2647
parsing/location.cmi \
2529
2648
utils/load_path.cmi \
2530
2649
utils/linkdeps.cmi \
2650
+
utils/format_doc.cmi \
2531
2651
asmcomp/emitaux.cmi \
2532
2652
asmcomp/emit.cmi \
2533
2653
utils/consistbl.cmi \
···
2548
2668
parsing/location.cmx \
2549
2669
utils/load_path.cmx \
2550
2670
utils/linkdeps.cmx \
2671
+
utils/format_doc.cmx \
2551
2672
asmcomp/emitaux.cmx \
2552
2673
asmcomp/emit.cmx \
2553
2674
utils/consistbl.cmx \
···
2563
2684
asmcomp/asmlink.cmi : \
2564
2685
utils/misc.cmi \
2565
2686
utils/linkdeps.cmi \
2687
+
utils/format_doc.cmi \
2566
2688
file_formats/cmx_format.cmi
2567
2689
asmcomp/asmpackager.cmo : \
2568
2690
parsing/unit_info.cmi \
···
2575
2697
utils/load_path.cmi \
2576
2698
lambda/lambda.cmi \
2577
2699
typing/ident.cmi \
2700
+
utils/format_doc.cmi \
2578
2701
middle_end/flambda/flambda_middle_end.cmi \
2579
2702
middle_end/flambda/export_info_for_pack.cmi \
2580
2703
middle_end/flambda/export_info.cmi \
···
2600
2723
utils/load_path.cmx \
2601
2724
lambda/lambda.cmx \
2602
2725
typing/ident.cmx \
2726
+
utils/format_doc.cmx \
2603
2727
middle_end/flambda/flambda_middle_end.cmx \
2604
2728
middle_end/flambda/export_info_for_pack.cmx \
2605
2729
middle_end/flambda/export_info.cmx \
···
2615
2739
asmcomp/asmgen.cmx \
2616
2740
asmcomp/asmpackager.cmi
2617
2741
asmcomp/asmpackager.cmi : \
2742
+
utils/format_doc.cmi \
2618
2743
typing/env.cmi \
2619
2744
middle_end/backend_intf.cmi
2620
2745
asmcomp/branch_relaxation.cmo : \
···
2882
3007
asmcomp/linear.cmi \
2883
3008
asmcomp/cmm.cmi
2884
3009
asmcomp/emitaux.cmo : \
3010
+
utils/format_doc.cmi \
2885
3011
asmcomp/emitenv.cmi \
2886
3012
lambda/debuginfo.cmi \
2887
3013
utils/config.cmi \
···
2891
3017
asmcomp/arch.cmi \
2892
3018
asmcomp/emitaux.cmi
2893
3019
asmcomp/emitaux.cmx : \
3020
+
utils/format_doc.cmx \
2894
3021
asmcomp/emitenv.cmi \
2895
3022
lambda/debuginfo.cmx \
2896
3023
utils/config.cmx \
···
2901
3028
asmcomp/emitaux.cmi
2902
3029
asmcomp/emitaux.cmi : \
2903
3030
asmcomp/linear.cmi \
3031
+
utils/format_doc.cmi \
2904
3032
asmcomp/emitenv.cmi \
2905
3033
lambda/debuginfo.cmi
2906
3034
asmcomp/emitenv.cmi : \
···
3031
3159
utils/misc.cmi \
3032
3160
asmcomp/mach.cmi \
3033
3161
parsing/location.cmi \
3162
+
utils/format_doc.cmi \
3034
3163
lambda/debuginfo.cmi \
3035
3164
asmcomp/dataflow.cmi \
3036
3165
asmcomp/cmm.cmi \
···
3040
3169
utils/misc.cmx \
3041
3170
asmcomp/mach.cmx \
3042
3171
parsing/location.cmx \
3172
+
utils/format_doc.cmx \
3043
3173
lambda/debuginfo.cmx \
3044
3174
asmcomp/dataflow.cmx \
3045
3175
asmcomp/cmm.cmx \
···
3415
3545
middle_end/backend_var.cmo : \
3416
3546
typing/path.cmi \
3417
3547
typing/ident.cmi \
3548
+
utils/format_doc.cmi \
3418
3549
lambda/debuginfo.cmi \
3419
3550
utils/clflags.cmi \
3420
3551
middle_end/backend_var.cmi
3421
3552
middle_end/backend_var.cmx : \
3422
3553
typing/path.cmx \
3423
3554
typing/ident.cmx \
3555
+
utils/format_doc.cmx \
3424
3556
lambda/debuginfo.cmx \
3425
3557
utils/clflags.cmx \
3426
3558
middle_end/backend_var.cmi
···
3500
3632
utils/load_path.cmi \
3501
3633
middle_end/linkage_name.cmi \
3502
3634
typing/ident.cmi \
3635
+
utils/format_doc.cmi \
3503
3636
middle_end/flambda/export_info.cmi \
3504
3637
typing/env.cmi \
3505
3638
utils/config.cmi \
···
3520
3653
utils/load_path.cmx \
3521
3654
middle_end/linkage_name.cmx \
3522
3655
typing/ident.cmx \
3656
+
utils/format_doc.cmx \
3523
3657
middle_end/flambda/export_info.cmx \
3524
3658
typing/env.cmx \
3525
3659
utils/config.cmx \
···
3535
3669
middle_end/flambda/base_types/set_of_closures_id.cmi \
3536
3670
middle_end/linkage_name.cmi \
3537
3671
typing/ident.cmi \
3672
+
utils/format_doc.cmi \
3538
3673
middle_end/flambda/export_info.cmi \
3539
3674
middle_end/compilation_unit.cmi \
3540
3675
file_formats/cmx_format.cmi \
···
3829
3964
parsing/location.cmi \
3830
3965
lambda/lambda.cmi \
3831
3966
typing/ident.cmi \
3967
+
utils/format_doc.cmi \
3832
3968
lambda/debuginfo.cmi \
3833
3969
parsing/asttypes.cmi \
3834
3970
lambda/tmc.cmi
···
3838
3974
parsing/location.cmx \
3839
3975
lambda/lambda.cmx \
3840
3976
typing/ident.cmx \
3977
+
utils/format_doc.cmx \
3841
3978
lambda/debuginfo.cmx \
3842
3979
parsing/asttypes.cmx \
3843
3980
lambda/tmc.cmi
···
3883
4020
parsing/location.cmi \
3884
4021
lambda/lambda.cmi \
3885
4022
typing/ident.cmi \
4023
+
utils/format_doc.cmi \
3886
4024
typing/env.cmi \
3887
4025
lambda/debuginfo.cmi \
3888
4026
utils/clflags.cmi \
···
3902
4040
parsing/location.cmx \
3903
4041
lambda/lambda.cmx \
3904
4042
typing/ident.cmx \
4043
+
utils/format_doc.cmx \
3905
4044
typing/env.cmx \
3906
4045
lambda/debuginfo.cmx \
3907
4046
utils/clflags.cmx \
···
3914
4053
parsing/location.cmi \
3915
4054
lambda/lambda.cmi \
3916
4055
typing/ident.cmi \
4056
+
utils/format_doc.cmi \
3917
4057
lambda/debuginfo.cmi \
3918
4058
parsing/asttypes.cmi
3919
4059
lambda/translcore.cmo : \
···
3934
4074
parsing/location.cmi \
3935
4075
lambda/lambda.cmi \
3936
4076
typing/ident.cmi \
4077
+
utils/format_doc.cmi \
3937
4078
typing/env.cmi \
3938
4079
lambda/debuginfo.cmi \
3939
4080
utils/config.cmi \
···
3959
4100
parsing/location.cmx \
3960
4101
lambda/lambda.cmx \
3961
4102
typing/ident.cmx \
4103
+
utils/format_doc.cmx \
3962
4104
typing/env.cmx \
3963
4105
lambda/debuginfo.cmx \
3964
4106
utils/config.cmx \
···
3972
4114
parsing/location.cmi \
3973
4115
lambda/lambda.cmi \
3974
4116
typing/ident.cmi \
4117
+
utils/format_doc.cmi \
3975
4118
typing/env.cmi \
3976
4119
lambda/debuginfo.cmi \
3977
4120
parsing/asttypes.cmi
···
3992
4135
parsing/location.cmi \
3993
4136
lambda/lambda.cmi \
3994
4137
typing/ident.cmi \
4138
+
utils/format_doc.cmi \
3995
4139
typing/env.cmi \
3996
4140
lambda/debuginfo.cmi \
3997
4141
typing/ctype.cmi \
···
4015
4159
parsing/location.cmx \
4016
4160
lambda/lambda.cmx \
4017
4161
typing/ident.cmx \
4162
+
utils/format_doc.cmx \
4018
4163
typing/env.cmx \
4019
4164
lambda/debuginfo.cmx \
4020
4165
typing/ctype.cmx \
···
4065
4210
parsing/location.cmi \
4066
4211
lambda/lambda.cmi \
4067
4212
typing/ident.cmi \
4213
+
utils/format_doc.cmi \
4068
4214
typing/env.cmi \
4069
4215
lambda/debuginfo.cmi \
4070
4216
utils/config.cmi \
···
4083
4229
parsing/location.cmx \
4084
4230
lambda/lambda.cmx \
4085
4231
typing/ident.cmx \
4232
+
utils/format_doc.cmx \
4086
4233
typing/env.cmx \
4087
4234
lambda/debuginfo.cmx \
4088
4235
utils/config.cmx \
···
4097
4244
parsing/location.cmi \
4098
4245
lambda/lambda.cmi \
4099
4246
typing/ident.cmi \
4247
+
utils/format_doc.cmi \
4100
4248
typing/env.cmi
4101
4249
lambda/value_rec_compiler.cmo : \
4102
4250
typing/value_rec_types.cmi \
···
4126
4274
typing/types.cmi \
4127
4275
utils/misc.cmi \
4128
4276
parsing/location.cmi \
4277
+
utils/format_doc.cmi \
4129
4278
utils/config.cmi \
4130
4279
utils/compression.cmi \
4131
4280
file_formats/cmi_format.cmi
···
4133
4282
typing/types.cmx \
4134
4283
utils/misc.cmx \
4135
4284
parsing/location.cmx \
4285
+
utils/format_doc.cmx \
4136
4286
utils/config.cmx \
4137
4287
utils/compression.cmx \
4138
4288
file_formats/cmi_format.cmi
4139
4289
file_formats/cmi_format.cmi : \
4140
4290
typing/types.cmi \
4141
-
utils/misc.cmi
4291
+
utils/misc.cmi \
4292
+
utils/format_doc.cmi
4142
4293
file_formats/cmo_format.cmi :
4143
4294
file_formats/cmt_format.cmo : \
4144
4295
parsing/unit_info.cmi \
···
4207
4358
utils/misc.cmi \
4208
4359
parsing/location.cmi \
4209
4360
asmcomp/linear.cmi \
4361
+
utils/format_doc.cmi \
4210
4362
utils/config.cmi \
4211
4363
asmcomp/cmm.cmi \
4212
4364
file_formats/linear_format.cmi
···
4214
4366
utils/misc.cmx \
4215
4367
parsing/location.cmx \
4216
4368
asmcomp/linear.cmx \
4369
+
utils/format_doc.cmx \
4217
4370
utils/config.cmx \
4218
4371
asmcomp/cmm.cmx \
4219
4372
file_formats/linear_format.cmi
···
6480
6633
parsing/parse.cmi \
6481
6634
utils/misc.cmi \
6482
6635
parsing/location.cmi \
6636
+
utils/format_doc.cmi \
6483
6637
utils/config.cmi \
6484
6638
utils/clflags.cmi \
6485
6639
utils/ccomp.cmi \
···
6493
6647
parsing/parse.cmx \
6494
6648
utils/misc.cmx \
6495
6649
parsing/location.cmx \
6650
+
utils/format_doc.cmx \
6496
6651
utils/config.cmx \
6497
6652
utils/clflags.cmx \
6498
6653
utils/ccomp.cmx \
···
6500
6655
parsing/ast_invariants.cmx \
6501
6656
driver/pparse.cmi
6502
6657
driver/pparse.cmi : \
6503
-
parsing/parsetree.cmi
6658
+
parsing/parsetree.cmi \
6659
+
utils/format_doc.cmi
6504
6660
toplevel/expunge.cmo : \
6505
6661
parsing/unit_info.cmi \
6506
6662
bytecomp/symtable.cmi \
···
6529
6685
parsing/longident.cmi \
6530
6686
parsing/lexer.cmi \
6531
6687
typing/ident.cmi \
6688
+
utils/format_doc.cmi \
6532
6689
typing/env.cmi \
6533
6690
typing/datarepr.cmi \
6534
6691
typing/ctype.cmi \
···
6547
6704
parsing/longident.cmx \
6548
6705
parsing/lexer.cmx \
6549
6706
typing/ident.cmx \
6707
+
utils/format_doc.cmx \
6550
6708
typing/env.cmx \
6551
6709
typing/datarepr.cmx \
6552
6710
typing/ctype.cmx \
···
6577
6735
parsing/lexer.cmi \
6578
6736
typing/ident.cmi \
6579
6737
toplevel/genprintval.cmi \
6738
+
utils/format_doc.cmi \
6580
6739
typing/env.cmi \
6581
6740
bytecomp/dll.cmi \
6582
6741
utils/config.cmi \
···
6607
6766
parsing/lexer.cmx \
6608
6767
typing/ident.cmx \
6609
6768
toplevel/genprintval.cmx \
6769
+
utils/format_doc.cmx \
6610
6770
typing/env.cmx \
6611
6771
bytecomp/dll.cmx \
6612
6772
utils/config.cmx \
···
6624
6784
typing/path.cmi \
6625
6785
parsing/parsetree.cmi \
6626
6786
typing/outcometree.cmi \
6787
+
typing/oprint.cmi \
6627
6788
parsing/longident.cmi \
6628
6789
parsing/location.cmi \
6629
6790
utils/load_path.cmi \
···
6694
6855
parsing/location.cmi \
6695
6856
utils/load_path.cmi \
6696
6857
parsing/lexer.cmi \
6858
+
utils/format_doc.cmi \
6697
6859
typing/env.cmi \
6698
6860
utils/config.cmi \
6699
6861
driver/compmisc.cmi \
···
6710
6872
parsing/location.cmx \
6711
6873
utils/load_path.cmx \
6712
6874
parsing/lexer.cmx \
6875
+
utils/format_doc.cmx \
6713
6876
typing/env.cmx \
6714
6877
utils/config.cmx \
6715
6878
driver/compmisc.cmx \
···
6723
6886
typing/path.cmi \
6724
6887
parsing/parsetree.cmi \
6725
6888
typing/outcometree.cmi \
6889
+
typing/oprint.cmi \
6726
6890
parsing/longident.cmi \
6727
6891
parsing/location.cmi \
6728
6892
utils/load_path.cmi \
···
7169
7333
utils/misc.cmi \
7170
7334
parsing/location.cmi \
7171
7335
bytecomp/instruct.cmi \
7336
+
utils/format_doc.cmi \
7172
7337
utils/config.cmi \
7173
7338
utils/compression.cmi \
7174
7339
file_formats/cmo_format.cmi \
···
7181
7346
utils/misc.cmx \
7182
7347
parsing/location.cmx \
7183
7348
bytecomp/instruct.cmx \
7349
+
utils/format_doc.cmx \
7184
7350
utils/config.cmx \
7185
7351
utils/compression.cmx \
7186
7352
file_formats/cmo_format.cmi \
···
7241
7407
parsing/location.cmi \
7242
7408
middle_end/linkage_name.cmi \
7243
7409
typing/ident.cmi \
7410
+
utils/format_doc.cmi \
7244
7411
middle_end/flambda/export_info.cmi \
7245
7412
middle_end/compilation_unit.cmi \
7246
7413
file_formats/cmxs_format.cmi \
···
7263
7430
parsing/location.cmx \
7264
7431
middle_end/linkage_name.cmx \
7265
7432
typing/ident.cmx \
7433
+
utils/format_doc.cmx \
7266
7434
middle_end/flambda/export_info.cmx \
7267
7435
middle_end/compilation_unit.cmx \
7268
7436
file_formats/cmxs_format.cmi \
···
7499
7667
debugger/input_handling.cmi \
7500
7668
debugger/history.cmi \
7501
7669
debugger/frames.cmi \
7670
+
utils/format_doc.cmi \
7502
7671
debugger/events.cmi \
7503
7672
debugger/eval.cmi \
7504
7673
typing/envaux.cmi \
···
7538
7707
debugger/input_handling.cmx \
7539
7708
debugger/history.cmx \
7540
7709
debugger/frames.cmx \
7710
+
utils/format_doc.cmx \
7541
7711
debugger/events.cmx \
7542
7712
debugger/eval.cmx \
7543
7713
typing/envaux.cmx \
···
7614
7784
bytecomp/instruct.cmi \
7615
7785
typing/ident.cmi \
7616
7786
debugger/frames.cmi \
7787
+
utils/format_doc.cmi \
7617
7788
debugger/events.cmi \
7618
7789
typing/env.cmi \
7619
7790
debugger/debugcom.cmi \
···
7634
7805
bytecomp/instruct.cmx \
7635
7806
typing/ident.cmx \
7636
7807
debugger/frames.cmx \
7808
+
utils/format_doc.cmx \
7637
7809
debugger/events.cmx \
7638
7810
typing/env.cmx \
7639
7811
debugger/debugcom.cmx \
···
7722
7894
parsing/longident.cmi \
7723
7895
utils/load_path.cmi \
7724
7896
typing/ident.cmi \
7897
+
utils/format_doc.cmi \
7725
7898
typing/env.cmi \
7726
7899
otherlibs/dynlink/dynlink.cmi \
7727
7900
typing/ctype.cmi \
···
7739
7912
parsing/longident.cmx \
7740
7913
utils/load_path.cmx \
7741
7914
typing/ident.cmx \
7915
+
utils/format_doc.cmx \
7742
7916
typing/env.cmx \
7743
7917
otherlibs/dynlink/dynlink.cmi \
7744
7918
typing/ctype.cmx \
···
7761
7935
utils/load_path.cmi \
7762
7936
debugger/input_handling.cmi \
7763
7937
debugger/frames.cmi \
7938
+
utils/format_doc.cmi \
7764
7939
debugger/exec.cmi \
7765
7940
debugger/debugger_config.cmi \
7766
7941
utils/config.cmi \
···
7784
7959
utils/load_path.cmx \
7785
7960
debugger/input_handling.cmx \
7786
7961
debugger/frames.cmx \
7962
+
utils/format_doc.cmx \
7787
7963
debugger/exec.cmx \
7788
7964
debugger/debugger_config.cmx \
7789
7965
utils/config.cmx \
···
8125
8301
ocamldoc/odoc_ast.cmi \
8126
8302
parsing/location.cmi \
8127
8303
parsing/lexer.cmi \
8304
+
utils/format_doc.cmi \
8128
8305
typing/env.cmi \
8129
8306
driver/compmisc.cmi \
8130
8307
utils/clflags.cmi \
···
8153
8330
ocamldoc/odoc_ast.cmx \
8154
8331
parsing/location.cmx \
8155
8332
parsing/lexer.cmx \
8333
+
utils/format_doc.cmx \
8156
8334
typing/env.cmx \
8157
8335
driver/compmisc.cmx \
8158
8336
utils/clflags.cmx \
+5
Makefile
+5
Makefile
···
63
63
utils_SOURCES = $(addprefix utils/, \
64
64
config.mli config.ml \
65
65
build_path_prefix_map.mli build_path_prefix_map.ml \
66
+
format_doc.mli format_doc.ml \
66
67
misc.mli misc.ml \
67
68
identifiable.mli identifiable.ml \
68
69
numbers.mli numbers.ml \
···
2202
2203
ocamlprof_SOURCES = \
2203
2204
config.mli config.ml \
2204
2205
build_path_prefix_map.mli build_path_prefix_map.ml \
2206
+
format_doc.mli format_doc.ml \
2205
2207
misc.mli misc.ml \
2206
2208
identifiable.mli identifiable.ml \
2207
2209
numbers.mli numbers.ml \
···
2228
2230
ocamlcp_ocamloptp_SOURCES = \
2229
2231
config.mli config.ml \
2230
2232
build_path_prefix_map.mli build_path_prefix_map.ml \
2233
+
format_doc.mli format_doc.ml \
2231
2234
misc.mli misc.ml \
2232
2235
profile.mli profile.ml \
2233
2236
warnings.mli warnings.ml \
···
2255
2258
ocamlmklib_SOURCES = \
2256
2259
config.ml \
2257
2260
build_path_prefix_map.ml \
2261
+
format_doc.ml \
2258
2262
misc.ml \
2259
2263
ocamlmklib.mli ocamlmklib.ml
2260
2264
···
2264
2268
ocamlmktop_SOURCES = \
2265
2269
config.mli config.ml \
2266
2270
build_path_prefix_map.mli build_path_prefix_map.ml \
2271
+
format_doc.mli format_doc.ml \
2267
2272
misc.mli misc.ml \
2268
2273
identifiable.mli identifiable.ml \
2269
2274
numbers.mli numbers.ml \
+3
-2
asmcomp/asmgen.ml
+3
-2
asmcomp/asmgen.ml
···
310
310
311
311
(* Error report *)
312
312
module Style = Misc.Style
313
+
let fprintf, dprintf = Format_doc.fprintf, Format_doc.dprintf
313
314
314
315
let report_error ppf = function
315
316
| Assembler_error file ->
···
317
318
Location.print_filename file
318
319
| Mismatched_for_pack saved ->
319
320
let msg = function
320
-
| None -> Format.dprintf "without %a" Style.inline_code "-for-pack"
321
-
| Some s -> Format.dprintf "with %a" Style.inline_code ("-for-pack " ^ s)
321
+
| None -> dprintf "without %a" Style.inline_code "-for-pack"
322
+
| Some s -> dprintf "with %a" Style.inline_code ("-for-pack " ^ s)
322
323
in
323
324
fprintf ppf
324
325
"This input file cannot be compiled %t: it was generated %t."
+1
-1
asmcomp/asmgen.mli
+1
-1
asmcomp/asmgen.mli
+1
-1
asmcomp/asmlibrarian.ml
+1
-1
asmcomp/asmlibrarian.ml
+1
-3
asmcomp/asmlibrarian.mli
+1
-3
asmcomp/asmlibrarian.mli
···
15
15
16
16
(* Build libraries of .cmx files *)
17
17
18
-
open Format
19
-
20
18
val create_archive: string list -> string -> unit
21
19
22
20
type error =
···
26
24
27
25
exception Error of error
28
26
29
-
val report_error: formatter -> error -> unit
27
+
val report_error: error Format_doc.printer
+1
-1
asmcomp/asmlink.ml
+1
-1
asmcomp/asmlink.ml
+1
-1
asmcomp/asmlink.mli
+1
-1
asmcomp/asmlink.mli
+1
-1
asmcomp/asmpackager.ml
+1
-1
asmcomp/asmpackager.ml
+1
-1
asmcomp/asmpackager.mli
+1
-1
asmcomp/asmpackager.mli
+1
-1
asmcomp/emitaux.ml
+1
-1
asmcomp/emitaux.ml
+1
-1
asmcomp/emitaux.mli
+1
-1
asmcomp/emitaux.mli
+1
-1
asmcomp/polling.ml
+1
-1
asmcomp/polling.ml
+1
-1
bytecomp/bytelibrarian.ml
+1
-1
bytecomp/bytelibrarian.ml
+1
-4
bytecomp/bytelibrarian.mli
+1
-4
bytecomp/bytelibrarian.mli
+1
-1
bytecomp/bytelink.ml
+1
-1
bytecomp/bytelink.ml
+1
-3
bytecomp/bytelink.mli
+1
-3
bytecomp/bytelink.mli
+1
-1
bytecomp/bytepackager.ml
+1
-1
bytecomp/bytepackager.ml
+1
-1
bytecomp/bytepackager.mli
+1
-1
bytecomp/bytepackager.mli
+1
-1
bytecomp/emitcode.ml
+1
-1
bytecomp/emitcode.ml
+4
-3
bytecomp/symtable.ml
+4
-3
bytecomp/symtable.ml
···
52
52
53
53
let description ppf = function
54
54
| Glob_compunit (Compunit cu) ->
55
-
Format.fprintf ppf "compilation unit %a" Style.inline_code (quote cu)
55
+
Format_doc.fprintf ppf "compilation unit %a"
56
+
Style.inline_code (quote cu)
56
57
| Glob_predef (Predef_exn exn) ->
57
-
Format.fprintf ppf "predefined exception %a"
58
+
Format_doc.fprintf ppf "predefined exception %a"
58
59
Style.inline_code (quote exn)
59
60
60
61
let of_ident id =
···
435
436
436
437
(* Error report *)
437
438
438
-
open Format
439
+
open Format_doc
439
440
440
441
let report_error ppf = function
441
442
| Undefined_global global ->
+2
-4
bytecomp/symtable.mli
+2
-4
bytecomp/symtable.mli
···
37
37
| Glob_compunit of compunit
38
38
| Glob_predef of predef
39
39
val name: t -> string
40
-
val description: Format.formatter -> t -> unit
40
+
val description: t Format_doc.printer
41
41
val of_ident: Ident.t -> t option
42
42
module Set : Set.S with type elt = t
43
43
module Map : Map.S with type key = t
···
90
90
91
91
exception Error of error
92
92
93
-
open Format
94
-
95
-
val report_error: formatter -> error -> unit
93
+
val report_error: error Format_doc.printer
96
94
97
95
val reset: unit -> unit
+3
-3
debugger/command_line.ml
+3
-3
debugger/command_line.ml
···
516
516
env_of_event !selected_event
517
517
with
518
518
| Envaux.Error msg ->
519
-
Envaux.report_error ppf msg;
519
+
Format_doc.compat Envaux.report_error ppf msg;
520
520
raise Toplevel
521
521
in
522
522
List.iter (print_expr depth !selected_event env ppf) exprs
···
533
533
env_of_event !selected_event
534
534
with
535
535
| Envaux.Error msg ->
536
-
Envaux.report_error ppf msg;
536
+
Format_doc.compat Envaux.report_error ppf msg;
537
537
raise Toplevel
538
538
in
539
539
let print_addr expr =
···
622
622
env_of_event !selected_event
623
623
with
624
624
| Envaux.Error msg ->
625
-
Envaux.report_error ppf msg;
625
+
Format_doc.compat Envaux.report_error ppf msg;
626
626
raise Toplevel
627
627
in
628
628
begin try
+11
-8
debugger/eval.ml
+11
-8
debugger/eval.ml
···
187
187
open Format
188
188
module Style = Misc.Style
189
189
190
+
let as_inline_code pr = Format_doc.compat @@ Style.as_inline_code pr
191
+
let inline_code = Format_doc.compat Style.inline_code
192
+
190
193
let report_error ppf = function
191
194
| Unbound_identifier id ->
192
195
fprintf ppf "@[Unbound identifier %a@]@."
193
-
Style.inline_code (Ident.name id)
196
+
inline_code (Ident.name id)
194
197
| Not_initialized_yet path ->
195
198
fprintf ppf
196
199
"@[The module path %a is not yet initialized.@ \
197
200
Please run program forward@ \
198
201
until its initialization code is executed.@]@."
199
-
(Style.as_inline_code Printtyp.path) path
202
+
(as_inline_code Printtyp.path) path
200
203
| Unbound_long_identifier lid ->
201
204
fprintf ppf "@[Unbound identifier %a@]@."
202
-
(Style.as_inline_code Printtyp.longident) lid
205
+
(as_inline_code Printtyp.longident) lid
203
206
| Unknown_name n ->
204
207
fprintf ppf "@[Unknown value name $%i@]@." n
205
208
| Tuple_index(ty, len, pos) ->
206
209
fprintf ppf
207
210
"@[Cannot extract field number %i from a %i-tuple of type@ %a@]@."
208
-
pos len (Style.as_inline_code Printtyp.type_expr) ty
211
+
pos len (as_inline_code Printtyp.type_expr) ty
209
212
| Array_index(len, pos) ->
210
213
fprintf ppf
211
214
"@[Cannot extract element number %i from an array of length %i@]@."
···
222
225
| Wrong_item_type(ty, pos) ->
223
226
fprintf ppf
224
227
"@[Cannot extract item number %i from a value of type@ %a@]@."
225
-
pos (Style.as_inline_code Printtyp.type_expr) ty
228
+
pos (as_inline_code Printtyp.type_expr) ty
226
229
| Wrong_label(ty, lbl) ->
227
230
fprintf ppf
228
231
"@[The record type@ %a@ has no label named %a@]@."
229
-
(Style.as_inline_code Printtyp.type_expr) ty
230
-
Style.inline_code lbl
232
+
(as_inline_code Printtyp.type_expr) ty
233
+
inline_code lbl
231
234
| Not_a_record ty ->
232
235
fprintf ppf
233
236
"@[The type@ %a@ is not a record type@]@."
234
-
(Style.as_inline_code Printtyp.type_expr) ty
237
+
(as_inline_code Printtyp.type_expr) ty
235
238
| No_result ->
236
239
fprintf ppf "@[No result available at current program event@]@."
+7
-5
debugger/loadprinter.ml
+7
-5
debugger/loadprinter.ml
···
140
140
141
141
open Format
142
142
module Style = Misc.Style
143
+
let quoted_longident =
144
+
Format_doc.compat @@ Style.as_inline_code Printtyp.longident
143
145
144
146
let report_error ppf = function
145
147
| Load_failure e ->
···
147
149
(Dynlink.error_message e)
148
150
| Unbound_identifier lid ->
149
151
fprintf ppf "@[Unbound identifier %a@]@."
150
-
(Style.as_inline_code Printtyp.longident) lid
152
+
quoted_longident lid
151
153
| Unavailable_module(md, lid) ->
152
154
fprintf ppf
153
155
"@[The debugger does not contain the code for@ %a.@ \
154
-
Please load an implementation of %s first.@]@."
155
-
(Style.as_inline_code Printtyp.longident) lid md
156
+
Please load an implementation of %s first.@]@."
157
+
quoted_longident lid md
156
158
| Wrong_type lid ->
157
159
fprintf ppf "@[%a has the wrong type for a printing function.@]@."
158
-
(Style.as_inline_code Printtyp.longident) lid
160
+
quoted_longident lid
159
161
| No_active_printer lid ->
160
162
fprintf ppf "@[%a is not currently active as a printing function.@]@."
161
-
(Style.as_inline_code Printtyp.longident) lid
163
+
quoted_longident lid
+2
-2
debugger/main.ml
+2
-2
debugger/main.ml
···
233
233
| Toplevel ->
234
234
exit 2
235
235
| Persistent_env.Error e ->
236
-
report Persistent_env.report_error e;
236
+
report (Format_doc.compat Persistent_env.report_error) e;
237
237
exit 2
238
238
| Cmi_format.Error e ->
239
-
report Cmi_format.report_error e;
239
+
report (Format_doc.compat Cmi_format.report_error) e;
240
240
exit 2
+1
debugger/printval.ml
+1
debugger/printval.ml
+1
-1
driver/pparse.ml
+1
-1
driver/pparse.ml
+1
-3
driver/pparse.mli
+1
-3
driver/pparse.mli
···
20
20
21
21
*)
22
22
23
-
open Format
24
-
25
23
type error =
26
24
| CannotRun of string
27
25
| WrongMagic of string
···
53
51
?restore:bool -> tool_name:string -> Parsetree.signature ->
54
52
Parsetree.signature
55
53
56
-
val report_error : formatter -> error -> unit
54
+
val report_error : error Format_doc.printer
57
55
58
56
59
57
val parse_implementation:
+5
-4
dune
+5
-4
dune
···
42
42
annot asttypes cmo_format outcometree parsetree value_rec_types)
43
43
(modules
44
44
;; UTILS
45
-
config build_path_prefix_map misc identifiable numbers arg_helper clflags
46
-
profile terminfo ccomp warnings consistbl strongly_connected_components
47
-
targetint load_path int_replace_polymorphic_compare binutils local_store
48
-
lazy_backtrack diffing diffing_with_keys unit_info compression linkdeps
45
+
config build_path_prefix_map misc identifiable numbers arg_helper
46
+
clflags profile terminfo ccomp format_doc warnings consistbl
47
+
strongly_connected_components targetint load_path
48
+
int_replace_polymorphic_compare binutils local_store lazy_backtrack diffing
49
+
diffing_with_keys unit_info compression linkdeps
49
50
50
51
;; PARSING
51
52
location longident docstrings syntaxerr ast_helper camlinternalMenhirLib
+1
-1
file_formats/cmi_format.ml
+1
-1
file_formats/cmi_format.ml
+1
-3
file_formats/cmi_format.mli
+1
-3
file_formats/cmi_format.mli
+1
-1
file_formats/linear_format.ml
+1
-1
file_formats/linear_format.ml
+1
-1
lambda/debuginfo.ml
+1
-1
lambda/debuginfo.ml
···
216
216
let rec print_compact ppf t =
217
217
let print_item item =
218
218
Format.fprintf ppf "%a:%i"
219
-
Location.print_filename item.dinfo_file
219
+
Location.Compat.print_filename item.dinfo_file
220
220
item.dinfo_line;
221
221
if item.dinfo_char_start >= 0 then begin
222
222
Format.fprintf ppf ",%i--%i" item.dinfo_char_start item.dinfo_char_end
+2
-2
lambda/matching.ml
+2
-2
lambda/matching.ml
···
93
93
open Typedtree
94
94
open Lambda
95
95
open Parmatch
96
-
open Printpat
96
+
open Printpat.Compat
97
97
98
98
module Scoped_location = Debuginfo.Scoped_location
99
99
···
3022
3022
Default_environment.pp defs
3023
3023
Context.pp ctx
3024
3024
(Format.pp_print_list ~pp_sep:Format.pp_print_cut
3025
-
Printpat.pretty_pat) input_fail_pats
3025
+
Printpat.Compat.pretty_pat) input_fail_pats
3026
3026
pp_partial (Jumps.partial jumps)
3027
3027
Jumps.pp jumps
3028
3028
;
+1
-1
lambda/printlambda.ml
+1
-1
lambda/printlambda.ml
···
112
112
| Record_unboxed false -> fprintf ppf "unboxed"
113
113
| Record_unboxed true -> fprintf ppf "inlined(unboxed)"
114
114
| Record_float -> fprintf ppf "float"
115
-
| Record_extension path -> fprintf ppf "ext(%a)" Printtyp.path path
115
+
| Record_extension path -> fprintf ppf "ext(%a)" Printtyp.Compat.path path
116
116
117
117
let block_shape ppf shape = match shape with
118
118
| None | Some [] -> ()
+2
-2
lambda/tmc.ml
+2
-2
lambda/tmc.ml
···
1003
1003
Ambiguous_constructor_arguments
1004
1004
{ explicit = false; arguments }) ->
1005
1005
let print_msg ppf =
1006
-
Format.fprintf ppf
1006
+
Format_doc.fprintf ppf
1007
1007
"%a:@ this@ constructor@ application@ may@ be@ \
1008
1008
TMC-transformed@ in@ several@ different@ ways.@ \
1009
1009
Please@ disambiguate@ by@ adding@ an@ explicit@ %a \
···
1028
1028
Ambiguous_constructor_arguments
1029
1029
{ explicit = true; arguments }) ->
1030
1030
let print_msg ppf =
1031
-
Format.fprintf ppf
1031
+
Format_doc.fprintf ppf
1032
1032
"%a:@ this@ constructor@ application@ may@ be@ \
1033
1033
TMC-transformed@ in@ several@ different@ ways.@ Only@ one@ of@ \
1034
1034
the@ arguments@ may@ become@ a@ TMC@ call,@ but@ several@ \
+1
-1
lambda/translclass.ml
+1
-1
lambda/translclass.ml
+1
-3
lambda/translclass.mli
+1
-3
lambda/translclass.mli
+1
-1
lambda/translcore.ml
+1
-1
lambda/translcore.ml
+1
-3
lambda/translcore.mli
+1
-3
lambda/translcore.mli
+5
-5
lambda/translmod.ml
+5
-5
lambda/translmod.ml
···
1657
1657
1658
1658
(* Error report *)
1659
1659
1660
-
open Format
1660
+
open Format_doc
1661
1661
module Style = Misc.Style
1662
1662
1663
1663
let print_cycle ppf cycle =
1664
-
let print_ident ppf (x,_) = Format.pp_print_string ppf (Ident.name x) in
1664
+
let print_ident ppf (x,_) = pp_print_string ppf (Ident.name x) in
1665
1665
let pp_sep ppf () = fprintf ppf "@ -> " in
1666
-
Format.fprintf ppf "%a%a%s"
1667
-
(Format.pp_print_list ~pp_sep print_ident) cycle
1666
+
fprintf ppf "%a%a%s"
1667
+
(pp_print_list ~pp_sep print_ident) cycle
1668
1668
pp_sep ()
1669
1669
(Ident.name @@ fst @@ List.hd cycle)
1670
1670
(* we repeat the first element to make the cycle more apparent *)
···
1674
1674
| Unnamed -> assert false (* can't be part of a cycle. *)
1675
1675
| Unsafe {reason;loc;subid} ->
1676
1676
let print fmt =
1677
-
let printer = Format.dprintf fmt
1677
+
let printer = doc_printf fmt
1678
1678
Style.inline_code (Ident.name id)
1679
1679
Style.inline_code (Ident.name subid) in
1680
1680
Location.mkloc printer loc in
+1
-1
lambda/translprim.ml
+1
-1
lambda/translprim.ml
+1
-3
lambda/translprim.mli
+1
-3
lambda/translprim.mli
+1
-1
manual/tests/Makefile
+1
-1
manual/tests/Makefile
···
15
15
16
16
cross-reference-checker: cross_reference_checker.ml
17
17
$(OCAMLC) $(ROOTDIR)/compilerlibs/ocamlcommon.cma \
18
-
-I $(ROOTDIR)/parsing -I $(ROOTDIR)/driver \
18
+
-I $(ROOTDIR)/utils -I $(ROOTDIR)/parsing -I $(ROOTDIR)/driver \
19
19
$< -o $@
20
20
21
21
# check cross-references between the manual and error messages
+2
-2
manual/tests/cross_reference_checker.ml
+2
-2
manual/tests/cross_reference_checker.ml
···
27
27
| No_aux_file
28
28
| Wrong_attribute_payload of Location.t
29
29
30
-
let pp_ref ppf = Format.pp_print_list ~pp_sep:( fun ppf () ->
31
-
Format.pp_print_string ppf ".") Format.pp_print_int ppf
30
+
let pp_ref ppf = Format_doc.pp_print_list ~pp_sep:( fun ppf () ->
31
+
Format_doc.pp_print_string ppf ".") Format_doc.pp_print_int ppf
32
32
33
33
let print_error error =
34
34
Location.print_report Format.std_formatter @@ match error with
+1
-1
middle_end/backend_var.ml
+1
-1
middle_end/backend_var.ml
···
29
29
let printf fmt = Format.fprintf ppf fmt in
30
30
printf "@[<hov 1>(";
31
31
printf "@[<hov 1>(module_path@ %a)@]@ "
32
-
Path.print module_path;
32
+
(Format_doc.compat Path.print) module_path;
33
33
if !Clflags.locations then
34
34
printf "@[<hov 1>(location@ %a)@]@ "
35
35
Debuginfo.print_compact location;
+1
-1
middle_end/compilenv.ml
+1
-1
middle_end/compilenv.ml
+1
-1
middle_end/compilenv.mli
+1
-1
middle_end/compilenv.mli
+1
-1
ocamldoc/odoc_analyse.ml
+1
-1
ocamldoc/odoc_analyse.ml
+1
ocamldoc/odoc_print.ml
+1
ocamldoc/odoc_print.ml
+1
ocamldoc/odoc_str.ml
+1
ocamldoc/odoc_str.ml
+1
-1
ocamltest/tsl_semantics.ml
+1
-1
ocamltest/tsl_semantics.ml
+2
otherlibs/dynlink/Makefile
+2
otherlibs/dynlink/Makefile
···
75
75
utils/binutils.ml \
76
76
utils/config.ml \
77
77
utils/build_path_prefix_map.ml \
78
+
utils/format_doc.ml \
78
79
utils/misc.ml \
79
80
utils/identifiable.ml \
80
81
utils/numbers.ml \
···
136
137
utils/binutils.ml \
137
138
utils/config.ml \
138
139
utils/build_path_prefix_map.ml \
140
+
utils/format_doc.ml \
139
141
utils/misc.ml
140
142
141
143
# Rules to make a local copy of the .ml and .mli files required. We also
+2
-2
otherlibs/dynlink/byte/dynlink.ml
+2
-2
otherlibs/dynlink/byte/dynlink.ml
···
120
120
let new_error : DT.linking_error =
121
121
match error with
122
122
| Symtable.Undefined_global global ->
123
-
Undefined_global
124
-
(Format.asprintf "%a" Symtable.Global.description global)
123
+
let desc = Format_doc.compat Symtable.Global.description in
124
+
Undefined_global (Format.asprintf "%a" desc global)
125
125
| Symtable.Unavailable_primitive s -> Unavailable_primitive s
126
126
| Symtable.Uninitialized_global global ->
127
127
Uninitialized_global (Symtable.Global.name global)
+3
-3
parsing/ast_mapper.ml
+3
-3
parsing/ast_mapper.ml
···
834
834
let extension_of_error {kind; main; sub} =
835
835
if kind <> Location.Report_error then
836
836
raise (Invalid_argument "extension_of_error: expected kind Report_error");
837
-
let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in
837
+
let str_of_msg msg = Format.asprintf "%a" Format_doc.format msg in
838
838
let extension_of_sub sub =
839
839
{ loc = sub.loc; txt = "ocaml.error" },
840
840
PStr ([Str.eval (Exp.constant
841
-
(Const.string ~loc:sub.loc (str_of_pp sub.txt)))])
841
+
(Const.string ~loc:sub.loc (str_of_msg sub.txt)))])
842
842
in
843
843
{ loc = main.loc; txt = "ocaml.error" },
844
844
PStr (Str.eval (Exp.constant
845
-
(Const.string ~loc:main.loc (str_of_pp main.txt))) ::
845
+
(Const.string ~loc:main.loc (str_of_msg main.txt))) ::
846
846
List.map (fun msg -> Str.extension (extension_of_sub msg)) sub)
847
847
848
848
let attribute_of_warning loc s =
+1
-1
parsing/attr_helper.ml
+1
-1
parsing/attr_helper.ml
+1
-1
parsing/attr_helper.mli
+1
-1
parsing/attr_helper.mli
+10
-10
parsing/builtin_attributes.ml
+10
-10
parsing/builtin_attributes.ml
···
109
109
| Some s -> s
110
110
| None -> ""
111
111
112
+
module Style = Misc.Style
112
113
let error_of_extension ext =
113
114
let submessage_from main_loc main_txt = function
114
115
| {pstr_desc=Pstr_extension
···
118
119
({pexp_desc=Pexp_constant
119
120
{pconst_desc=Pconst_string(msg, _, _); _}}, _)}
120
121
]) ->
121
-
{ Location.loc; txt = fun ppf -> Format.pp_print_text ppf msg }
122
+
Location.msg ~loc "%a" Format_doc.pp_print_text msg
122
123
| _ ->
123
-
{ Location.loc; txt = fun ppf ->
124
-
Format.fprintf ppf
125
-
"Invalid syntax for sub-message of extension '%s'." main_txt }
124
+
Location.msg ~loc "Invalid syntax for sub-message of extension %a."
125
+
Style.inline_code main_txt
126
126
end
127
127
| {pstr_desc=Pstr_extension (({txt; loc}, _), _)} ->
128
-
{ Location.loc; txt = fun ppf ->
129
-
Format.fprintf ppf "Uninterpreted extension '%s'." txt }
128
+
Location.msg ~loc "Uninterpreted extension '%a'."
129
+
Style.inline_code txt
130
130
| _ ->
131
-
{ Location.loc = main_loc; txt = fun ppf ->
132
-
Format.fprintf ppf
133
-
"Invalid syntax for sub-message of extension '%s'." main_txt }
131
+
Location.msg ~loc:main_loc
132
+
"Invalid syntax for sub-message of extension %a."
133
+
Style.inline_code main_txt
134
134
in
135
135
match ext with
136
136
| ({txt = ("ocaml.error"|"error") as txt; loc}, p) ->
···
141
141
{pconst_desc=Pconst_string(msg, _, _)}}, _)}::
142
142
inner) ->
143
143
let sub = List.map (submessage_from loc txt) inner in
144
-
Location.error_of_printer ~loc ~sub Format.pp_print_text msg
144
+
Location.error_of_printer ~loc ~sub Format_doc.pp_print_text msg
145
145
| _ ->
146
146
Location.errorf ~loc "Invalid syntax for extension '%s'." txt
147
147
end
+1
-1
parsing/lexer.mll
+1
-1
parsing/lexer.mll
+54
-42
parsing/location.ml
+54
-42
parsing/location.ml
···
119
119
incr num_loc_lines
120
120
121
121
(* This is used by the toplevel and the report printers below. *)
122
-
let separate_new_message ppf =
122
+
let separate_new_message ppf () =
123
123
if not (is_first_message ()) then begin
124
-
Format.pp_print_newline ppf ();
124
+
Format_doc.pp_print_newline ppf ();
125
125
incr num_loc_lines
126
126
end
127
127
···
146
146
pp_print_flush ppf ();
147
147
pp_set_formatter_out_functions ppf out_functions
148
148
149
+
(** {1 Printing setup }*)
150
+
149
151
let setup_tags () =
150
152
Misc.Style.setup !Clflags.color
153
+
154
+
module Fmt = Format_doc
151
155
152
156
(******************************************************************************)
153
157
(* Printing locations, e.g. 'File "foo.ml", line 3, characters 10-12' *)
···
205
209
if !Clflags.absname then absolute_path file else file
206
210
207
211
let print_filename ppf file =
208
-
Format.pp_print_string ppf (show_filename file)
212
+
Fmt.pp_print_string ppf (show_filename file)
209
213
210
214
(* Best-effort printing of the text describing a location, of the form
211
215
'File "foo.ml", line 3, characters 10-12'.
···
242
246
if !first then (first := false; String.capitalize_ascii s)
243
247
else s in
244
248
let comma () =
245
-
if !first then () else Format.fprintf ppf ", " in
249
+
if !first then () else Fmt.fprintf ppf ", " in
246
250
247
-
Format.fprintf ppf "@{<loc>";
251
+
Fmt.fprintf ppf "@{<loc>";
248
252
249
253
if file_valid file then
250
-
Format.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file;
254
+
Fmt.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file;
251
255
252
256
(* Print "line 1" in the case of a dummy line number. This is to please the
253
257
existing setup of editors that parse locations in error messages (e.g.
···
256
260
let startline = if line_valid startline then startline else 1 in
257
261
let endline = if line_valid endline then endline else startline in
258
262
begin if startline = endline then
259
-
Format.fprintf ppf "%s %i" (capitalize "line") startline
263
+
Fmt.fprintf ppf "%s %i" (capitalize "line") startline
260
264
else
261
-
Format.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline
265
+
Fmt.fprintf ppf "%s %i-%i" (capitalize "lines") startline endline
262
266
end;
263
267
264
268
if chars_valid ~startchar ~endchar then (
265
269
comma ();
266
-
Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar
270
+
Fmt.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar
267
271
);
268
272
269
-
Format.fprintf ppf "@}"
273
+
Fmt.fprintf ppf "@}"
270
274
271
275
(* Print a comma-separated list of locations *)
272
276
let print_locs ppf locs =
273
-
Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")
277
+
Fmt.pp_print_list ~pp_sep:(fun ppf () -> Fmt.fprintf ppf ",@ ")
274
278
print_loc ppf locs
279
+
280
+
module Compat = struct
281
+
let print_filename = Fmt.compat print_filename
282
+
let print_loc = Fmt.compat print_loc
283
+
let print_locs = Fmt.compat print_locs
284
+
let separate_new_message = Fmt.compat separate_new_message
285
+
end
275
286
276
287
(******************************************************************************)
277
288
(* An interval set structure; additionally, it stores user-provided information
···
497
508
Option.fold ~some:Int.to_string ~none:"" lnum,
498
509
start_pos))
499
510
in
500
-
Format.fprintf ppf "@[<v>";
511
+
Fmt.fprintf ppf "@[<v>";
501
512
begin match lines with
502
513
| [] | [("", _, _)] -> ()
503
514
| [(line, line_nb, line_start_cnum)] ->
504
515
(* Single-line error *)
505
-
Format.fprintf ppf "%s | %s@," line_nb line;
506
-
Format.fprintf ppf "%*s " (String.length line_nb) "";
516
+
Fmt.fprintf ppf "%s | %s@," line_nb line;
517
+
Fmt.fprintf ppf "%*s " (String.length line_nb) "";
507
518
(* Iterate up to [rightmost], which can be larger than the length of
508
519
the line because we may point to a location after the end of the
509
520
last token on the line, for instance:
···
515
526
for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do
516
527
let pos = line_start_cnum + i in
517
528
if ISet.is_start iset ~pos <> None then
518
-
Format.fprintf ppf "@{<%s>" highlight_tag;
519
-
if ISet.mem iset ~pos then Format.pp_print_char ppf '^'
529
+
Fmt.fprintf ppf "@{<%s>" highlight_tag;
530
+
if ISet.mem iset ~pos then Fmt.pp_print_char ppf '^'
520
531
else if i < String.length line then begin
521
532
(* For alignment purposes, align using a tab for each tab in the
522
533
source code *)
523
-
if line.[i] = '\t' then Format.pp_print_char ppf '\t'
524
-
else Format.pp_print_char ppf ' '
534
+
if line.[i] = '\t' then Fmt.pp_print_char ppf '\t'
535
+
else Fmt.pp_print_char ppf ' '
525
536
end;
526
537
if ISet.is_end iset ~pos <> None then
527
-
Format.fprintf ppf "@}"
538
+
Fmt.fprintf ppf "@}"
528
539
done;
529
-
Format.fprintf ppf "@}@,"
540
+
Fmt.fprintf ppf "@}@,"
530
541
| _ ->
531
542
(* Multi-line error *)
532
-
Misc.pp_two_columns ~sep:"|" ~max_lines ppf
543
+
Fmt.pp_two_columns ~sep:"|" ~max_lines ppf
533
544
@@ List.map (fun (line, line_nb, line_start_cnum) ->
534
545
let line = String.mapi (fun i car ->
535
546
if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.'
···
537
548
(line_nb, line)
538
549
) lines
539
550
end;
540
-
Format.fprintf ppf "@]"
551
+
Fmt.fprintf ppf "@]"
541
552
542
553
543
554
···
633
644
(******************************************************************************)
634
645
(* Reporting errors and warnings *)
635
646
636
-
type msg = (Format.formatter -> unit) loc
647
+
type msg = Fmt.t loc
637
648
638
649
let msg ?(loc = none) fmt =
639
-
Format.kdprintf (fun txt -> { loc; txt }) fmt
650
+
Fmt.kdoc_printf (fun txt -> { loc; txt }) fmt
640
651
641
652
type report_kind =
642
653
| Report_error
···
649
660
kind : report_kind;
650
661
main : msg;
651
662
sub : msg list;
652
-
footnote: unit -> (Format.formatter -> unit) option;
663
+
footnote: Fmt.t option;
653
664
}
654
665
655
666
type report_printer = {
···
662
673
pp_main_loc : report_printer -> report ->
663
674
Format.formatter -> t -> unit;
664
675
pp_main_txt : report_printer -> report ->
665
-
Format.formatter -> (Format.formatter -> unit) -> unit;
676
+
Format.formatter -> Fmt.t -> unit;
666
677
pp_submsgs : report_printer -> report ->
667
678
Format.formatter -> msg list -> unit;
668
679
pp_submsg : report_printer -> report ->
···
670
681
pp_submsg_loc : report_printer -> report ->
671
682
Format.formatter -> t -> unit;
672
683
pp_submsg_txt : report_printer -> report ->
673
-
Format.formatter -> (Format.formatter -> unit) -> unit;
684
+
Format.formatter -> Fmt.t -> unit;
674
685
}
675
686
676
687
let is_dummy_loc loc =
···
726
737
| Misc.Error_style.Short ->
727
738
()
728
739
in
729
-
Format.fprintf ppf "@[<v>%a:@ %a@]" print_loc loc highlight loc
740
+
Format.fprintf ppf "@[<v>%a:@ %a@]" Compat.print_loc loc
741
+
(Fmt.compat highlight) loc
730
742
in
731
-
let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in
743
+
let pp_txt ppf txt = Format.fprintf ppf "@[%a@]" Fmt.format txt in
732
744
let pp_footnote ppf f =
733
-
Option.iter (Format.fprintf ppf "@,%a" pp_txt) (f ())
745
+
Option.iter (Format.fprintf ppf "@,%a" pp_txt) f
734
746
in
735
747
let pp self ppf report =
736
748
setup_tags ();
737
-
separate_new_message ppf;
749
+
Fmt.compat separate_new_message ppf ();
738
750
(* Make sure we keep [num_loc_lines] updated.
739
751
The tabulation box is here to give submessage the option
740
752
to be aligned with the main message box
···
801
813
let pp_main_loc _ _ _ _ = () in
802
814
let pp_submsg_loc _ _ ppf loc =
803
815
if not loc.loc_ghost then
804
-
Format.fprintf ppf "%a:@ " print_loc loc in
816
+
Format.fprintf ppf "%a:@ " Compat.print_loc loc in
805
817
{ batch_mode_printer with pp; pp_main_loc; pp_submsg_loc }
806
818
807
819
let best_toplevel_printer () =
···
829
841
(* Reporting errors *)
830
842
831
843
type error = report
832
-
type delayed_msg = unit -> (Format.formatter -> unit) option
844
+
type delayed_msg = unit -> Fmt.t option
833
845
834
846
let report_error ppf err =
835
847
print_report ppf err
836
848
837
849
let mkerror loc sub footnote txt =
838
-
{ kind = Report_error; main = { loc; txt }; sub; footnote }
850
+
{ kind = Report_error; main = { loc; txt }; sub; footnote=footnote () }
839
851
840
852
let errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) =
841
-
Format.kdprintf (mkerror loc sub footnote)
853
+
Fmt.kdoc_printf (mkerror loc sub footnote)
842
854
843
855
let error ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) msg_str =
844
-
mkerror loc sub footnote (fun ppf -> Format.pp_print_string ppf msg_str)
856
+
mkerror loc sub footnote Fmt.(Core.string msg_str empty)
845
857
846
858
let error_of_printer ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) pp x =
847
-
mkerror loc sub footnote (fun ppf -> pp ppf x)
859
+
mkerror loc sub footnote (Fmt.doc_printf "%a" pp x)
848
860
849
861
let error_of_printer_file print x =
850
862
error_of_printer ~loc:(in_file !input_name) print x
···
857
869
match report w with
858
870
| `Inactive -> None
859
871
| `Active { Warnings.id; message; is_error; sub_locs } ->
860
-
let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in
872
+
let msg_of_str str = Format_doc.(empty |> Core.string str) in
861
873
let kind = mk is_error id in
862
874
let main = { loc; txt = msg_of_str message } in
863
875
let sub = List.map (fun (loc, sub_message) ->
864
876
{ loc; txt = msg_of_str sub_message }
865
877
) sub_locs in
866
-
Some { kind; main; sub; footnote=Fun.const None }
878
+
Some { kind; main; sub; footnote=None }
867
879
868
880
869
881
let default_warning_reporter =
···
913
925
module Style = Misc.Style
914
926
915
927
let auto_include_alert lib =
916
-
let message = Format.asprintf "\
928
+
let message = Fmt.asprintf "\
917
929
OCaml's lib directory layout changed in 5.0. The %a subdirectory has been \
918
930
automatically added to the search path, but you should add %a to the \
919
931
command-line to silence this alert (e.g. by adding %a to the list of \
···
932
944
prerr_alert none alert
933
945
934
946
let deprecated_script_alert program =
935
-
let message = Format.asprintf "\
947
+
let message = Fmt.asprintf "\
936
948
Running %a where the first argument is an implicit basename with no \
937
949
extension (e.g. %a) is deprecated. Either rename the script \
938
950
(%a) or qualify the basename (%a)"
···
999
1011
)
1000
1012
1001
1013
let raise_errorf ?(loc = none) ?(sub = []) ?(footnote=Fun.const None) =
1002
-
Format.kdprintf (fun txt -> raise (Error (mkerror loc sub footnote txt)))
1014
+
Fmt.kdoc_printf (fun txt -> raise (Error (mkerror loc sub footnote txt)))
+23
-20
parsing/location.mli
+23
-20
parsing/location.mli
···
88
88
(** {1 Toplevel-specific functions} *)
89
89
90
90
val echo_eof: unit -> unit
91
-
val separate_new_message: formatter -> unit
91
+
val separate_new_message: unit Format_doc.printer
92
92
val reset: unit -> unit
93
93
94
94
···
169
169
(** In -absname mode, return the absolute path for this filename.
170
170
Otherwise, returns the filename unchanged. *)
171
171
172
-
val print_filename: formatter -> string -> unit
173
-
174
-
val print_loc: formatter -> t -> unit
175
-
val print_locs: formatter -> t list -> unit
172
+
module Compat: sig
173
+
val print_filename: formatter -> string -> unit
174
+
val print_loc: formatter -> t -> unit
175
+
val print_locs: formatter -> t list -> unit
176
+
val separate_new_message: formatter -> unit -> unit
177
+
end
176
178
179
+
val print_filename: string Format_doc.printer
180
+
val print_loc: t Format_doc.printer
181
+
val print_locs: t list Format_doc.printer
177
182
178
183
(** {1 Toplevel-specific location highlighting} *)
179
184
···
185
190
186
191
(** {2 The type of reports and report printers} *)
187
192
188
-
type msg = (Format.formatter -> unit) loc
193
+
type msg = Format_doc.t loc
189
194
190
-
val msg: ?loc:t -> ('a, Format.formatter, unit, msg) format4 -> 'a
195
+
val msg: ?loc:t -> ('a, Format_doc.formatter, unit, msg) format4 -> 'a
191
196
192
197
type report_kind =
193
198
| Report_error
···
200
205
kind : report_kind;
201
206
main : msg;
202
207
sub : msg list;
203
-
footnote: unit -> (Format.formatter -> unit) option
208
+
footnote: Format_doc.t option
204
209
}
205
210
206
211
type report_printer = {
···
213
218
pp_main_loc : report_printer -> report ->
214
219
Format.formatter -> t -> unit;
215
220
pp_main_txt : report_printer -> report ->
216
-
Format.formatter -> (Format.formatter -> unit) -> unit;
221
+
Format.formatter -> Format_doc.t -> unit;
217
222
pp_submsgs : report_printer -> report ->
218
223
Format.formatter -> msg list -> unit;
219
224
pp_submsg : report_printer -> report ->
···
221
226
pp_submsg_loc : report_printer -> report ->
222
227
Format.formatter -> t -> unit;
223
228
pp_submsg_txt : report_printer -> report ->
224
-
Format.formatter -> (Format.formatter -> unit) -> unit;
229
+
Format.formatter -> Format_doc.t -> unit;
225
230
}
226
231
(** A printer for [report]s, defined using open-recursion.
227
232
The goal is to make it easy to define new printers by re-using code from
···
322
327
type error = report
323
328
(** An [error] is a [report] which [report_kind] must be [Report_error]. *)
324
329
325
-
type delayed_msg = unit -> (formatter->unit) option
330
+
type delayed_msg = unit -> Format_doc.t option
326
331
327
-
val error: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg-> string -> error
332
+
val error: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg -> string -> error
328
333
329
-
val errorf:
330
-
?loc:t -> ?sub:msg list -> ?footnote:delayed_msg ->
331
-
('a, Format.formatter, unit, error) format4 -> 'a
334
+
val errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg ->
335
+
('a, Format_doc.formatter, unit, error) format4 -> 'a
332
336
333
-
val error_of_printer:
334
-
?loc:t -> ?sub:msg list -> ?footnote:delayed_msg ->
335
-
(formatter -> 'a -> unit) -> 'a -> error
337
+
val error_of_printer: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg ->
338
+
(Format_doc.formatter -> 'a -> unit) -> 'a -> error
336
339
337
-
val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error
340
+
val error_of_printer_file: (Format_doc.formatter -> 'a -> unit) -> 'a -> error
338
341
339
342
340
343
(** {1 Automatically reporting errors for raised exceptions} *)
···
358
361
printed. The exception will be caught, but nothing will be printed *)
359
362
360
363
val raise_errorf: ?loc:t -> ?sub:msg list -> ?footnote:delayed_msg ->
361
-
('a, Format.formatter, unit, 'b) format4 -> 'a
364
+
('a, Format_doc.formatter, unit, 'b) format4 -> 'a
362
365
363
366
val report_exception: formatter -> exn -> unit
364
367
(** Reraise the exception if it is unknown. *)
+6
-6
parsing/parse.ml
+6
-6
parsing/parse.ml
···
138
138
Location.errorf ~loc
139
139
"In this scoped type, variable %a \
140
140
is reserved for the local type %a."
141
-
(Style.as_inline_code Pprintast.tyvar) var
141
+
(Style.as_inline_code Pprintast.Doc.tyvar) var
142
142
Style.inline_code var
143
143
| Other loc ->
144
144
Location.errorf ~loc "Syntax error"
···
148
148
| Invalid_package_type (loc, ipt) ->
149
149
let invalid ppf ipt = match ipt with
150
150
| Syntaxerr.Parameterized_types ->
151
-
Format.fprintf ppf "parametrized types are not supported"
151
+
Format_doc.fprintf ppf "parametrized types are not supported"
152
152
| Constrained_types ->
153
-
Format.fprintf ppf "constrained types are not supported"
153
+
Format_doc.fprintf ppf "constrained types are not supported"
154
154
| Private_types ->
155
-
Format.fprintf ppf "private types are not supported"
155
+
Format_doc.fprintf ppf "private types are not supported"
156
156
| Not_with_type ->
157
-
Format.fprintf ppf "only %a constraints are supported"
157
+
Format_doc.fprintf ppf "only %a constraints are supported"
158
158
Style.inline_code "with type t ="
159
159
| Neither_identifier_nor_with_type ->
160
-
Format.fprintf ppf
160
+
Format_doc.fprintf ppf
161
161
"only module type identifier and %a constraints are supported"
162
162
Style.inline_code "with type"
163
163
in
+42
-32
parsing/pprintast.ml
+42
-32
parsing/pprintast.ml
···
94
94
let needs_spaces txt =
95
95
first_is '*' txt || last_is '*' txt
96
96
97
+
let tyvar_of_name s =
98
+
if String.length s >= 2 && s.[1] = '\'' then
99
+
(* without the space, this would be parsed as
100
+
a character literal *)
101
+
"' " ^ s
102
+
else if Lexer.is_keyword s then
103
+
"'\\#" ^ s
104
+
else if String.equal s "_" then
105
+
s
106
+
else
107
+
"'" ^ s
108
+
109
+
module Doc = struct
97
110
(* Turn an arbitrary variable name into a valid OCaml identifier by adding \#
98
111
in case it is a keyword, or parenthesis when it is an infix or prefix
99
112
operator. *)
100
-
let ident_of_name ppf txt =
101
-
let format : (_, _, _) format =
102
-
if Lexer.is_keyword txt then "\\#%s"
103
-
else if not (needs_parens txt) then "%s"
104
-
else if needs_spaces txt then "(@;%s@;)"
105
-
else "(%s)"
106
-
in fprintf ppf format txt
113
+
let ident_of_name ppf txt =
114
+
let format : (_, _, _) format =
115
+
if Lexer.is_keyword txt then "\\#%s"
116
+
else if not (needs_parens txt) then "%s"
117
+
else if needs_spaces txt then "(@;%s@;)"
118
+
else "(%s)"
119
+
in Format_doc.fprintf ppf format txt
107
120
108
-
let ident_of_name_loc ppf s = ident_of_name ppf s.txt
109
-
110
-
let protect_longident ppf print_longident longprefix txt =
121
+
let protect_longident ppf print_longident longprefix txt =
111
122
if not (needs_parens txt) then
112
-
fprintf ppf "%a.%a" print_longident longprefix ident_of_name txt
123
+
Format_doc.fprintf ppf "%a.%a"
124
+
print_longident longprefix
125
+
ident_of_name txt
113
126
else if needs_spaces txt then
114
-
fprintf ppf "%a.(@;%s@;)" print_longident longprefix txt
127
+
Format_doc.fprintf ppf "%a.(@;%s@;)" print_longident longprefix txt
115
128
else
116
-
fprintf ppf "%a.(%s)" print_longident longprefix txt
129
+
Format_doc.fprintf ppf "%a.(%s)" print_longident longprefix txt
130
+
131
+
let rec longident f = function
132
+
| Lident s -> ident_of_name f s
133
+
| Ldot(y,s) -> protect_longident f longident y s
134
+
| Lapply (y,s) ->
135
+
Format_doc.fprintf f "%a(%a)" longident y longident s
136
+
137
+
let tyvar ppf s =
138
+
Format_doc.fprintf ppf "%s" (tyvar_of_name s)
139
+
end
140
+
141
+
let longident ppf l = Format_doc.compat Doc.longident ppf l
142
+
let ident_of_name ppf i = Format_doc.compat Doc.ident_of_name ppf i
143
+
let ident_of_name_loc ppf s = ident_of_name ppf s.txt
117
144
118
145
type space_formatter = (unit, Format.formatter, unit) format
119
146
···
225
252
if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")")
226
253
else fu f x
227
254
228
-
let rec longident f = function
229
-
| Lident s -> ident_of_name f s
230
-
| Ldot(y,s) -> protect_longident f longident y s
231
-
| Lapply (y,s) ->
232
-
pp f "%a(%a)" longident y longident s
233
-
234
255
let longident_loc f x = pp f "%a" longident x.txt
235
256
236
257
let constant_desc f = function
···
279
300
280
301
let constant_string f s = pp f "%S" s
281
302
282
-
let tyvar_of_name s =
283
-
if String.length s >= 2 && s.[1] = '\'' then
284
-
(* without the space, this would be parsed as
285
-
a character literal *)
286
-
"' " ^ s
287
-
else if Lexer.is_keyword s then
288
-
"'\\#" ^ s
289
-
else if String.equal s "_" then
290
-
s
291
-
else
292
-
"'" ^ s
303
+
293
304
294
-
let tyvar ppf s =
295
-
Format.fprintf ppf "%s" (tyvar_of_name s)
305
+
let tyvar ppf v = Format_doc.compat Doc.tyvar ppf v
296
306
297
307
let tyvar_loc f str = tyvar f str.txt
298
308
let string_quot f x = pp f "`%a" ident_of_name x
+6
parsing/pprintast.mli
+6
parsing/pprintast.mli
···
59
59
(** Print a type variable name as a valid identifier, taking care of the
60
60
special treatment required for the single quote character in second
61
61
position, or for keywords by escaping them with \#. No-op on "_". *)
62
+
63
+
(** {!Format_doc} functions for error messages *)
64
+
module Doc:sig
65
+
val longident: Longident.t Format_doc.printer
66
+
val tyvar: string Format_doc.printer
67
+
end
+5
-3
testsuite/tests/formatting/errors_batch.ml
+5
-3
testsuite/tests/formatting/errors_batch.ml
···
2
2
include ocamlcommon;
3
3
*)
4
4
5
+
module Fmt = Format_doc
6
+
5
7
let () =
6
8
let open Location in
7
9
(* Some dummy locations for demo purposes *)
···
27
29
} in
28
30
let report = {
29
31
kind = Report_error;
30
-
main = msg ~loc:loc1 "%a" Format.pp_print_text
32
+
main = msg ~loc:loc1 "%a" Fmt.pp_print_text
31
33
"These are the contents of the main error message. \
32
34
It is very long and should wrap across several lines.";
33
35
sub = [
34
36
msg ~loc:loc2 "A located first sub-message.";
35
-
msg ~loc:loc3 "%a" Format.pp_print_text
37
+
msg ~loc:loc3 "%a" Fmt.pp_print_text
36
38
"Longer sub-messages that do not fit on the \
37
39
same line as the location get indented.";
38
40
msg "@[<v>This second sub-message does not have \
39
41
a location;@,ghost locations of submessages are \
40
42
not printed.@]";
41
43
];
42
-
footnote=Fun.const None;
44
+
footnote=None;
43
45
} in
44
46
print_report Format.std_formatter report
+2
-2
testsuite/tests/typing-misc/pr6416.ml
+2
-2
testsuite/tests/typing-misc/pr6416.ml
···
55
55
Constructors do not match:
56
56
"A of t"
57
57
is not the same as:
58
-
"A of t"
58
+
"A of t/2"
59
59
The type "t" is not equal to the type "t/2"
60
60
Line 4, characters 9-19:
61
61
Definition of type "t"
···
121
121
Constructors do not match:
122
122
"A of T.t"
123
123
is not the same as:
124
-
"A of T.t"
124
+
"A of T/2.t"
125
125
The type "T.t" is not equal to the type "T/2.t"
126
126
Line 5, characters 6-34:
127
127
Definition of module "T"
+1
-1
testsuite/tests/utils/edit_distance.ml
+1
-1
testsuite/tests/utils/edit_distance.ml
+1
-1
testsuite/tests/utils/find_first_mono.ml
+1
-1
testsuite/tests/utils/find_first_mono.ml
+1
-1
testsuite/tests/utils/magic_number.ml
+1
-1
testsuite/tests/utils/magic_number.ml
+1
-1
testsuite/tests/utils/overflow_detection.ml
+1
-1
testsuite/tests/utils/overflow_detection.ml
+1
-1
testsuite/tests/utils/test_strongly_connected_components.ml
+1
-1
testsuite/tests/utils/test_strongly_connected_components.ml
···
1
1
(* TEST
2
2
include config;
3
3
include testing;
4
-
binary_modules = "config build_path_prefix_map misc identifiable numbers strongly_connected_components";
4
+
binary_modules = "config build_path_prefix_map format_doc misc identifiable numbers strongly_connected_components";
5
5
bytecode;
6
6
*)
7
7
+5
-4
tools/dumpobj.ml
+5
-4
tools/dumpobj.ml
···
161
161
if n >= Array.length !globals || n < 0
162
162
then print_string "<global table overflow>"
163
163
else match !globals.(n) with
164
-
| Glob glob -> print_string
165
-
(Format.asprintf "%a" Symtable.Global.description glob)
164
+
| Glob glob ->
165
+
let desc = Format_doc.compat Symtable.Global.description in
166
+
print_string (Format.asprintf "%a" desc glob)
166
167
| Constant obj -> print_obj obj
167
168
end
168
169
···
190
191
then print_string "<global table overflow>"
191
192
else match !globals.(n) with
192
193
| Glob glob ->
193
-
print_string
194
-
(Format.asprintf "%a" Symtable.Global.description glob)
194
+
let desc = Format_doc.compat Symtable.Global.description in
195
+
print_string (Format.asprintf "%a" desc glob)
195
196
| Constant _ -> print_string "<unexpected constant>"
196
197
end
197
198
+4
-4
tools/objinfo.ml
+4
-4
tools/objinfo.ml
···
122
122
List.iter (fun (loc, item) ->
123
123
let pp_loc fmt { Location.txt; loc } =
124
124
Format.fprintf fmt "%a (%a)"
125
-
Pprintast.longident txt Location.print_loc loc
125
+
Pprintast.longident txt Location.Compat.print_loc loc
126
126
in
127
127
Format.printf "@[<hov 2>%a:@ %a@]@;"
128
128
Shape_reduce.print_result item pp_loc loc)
···
156
156
in
157
157
let pp_loc fmt { Location.txt; loc } =
158
158
Format.fprintf fmt "%s (%a)"
159
-
txt Location.print_loc loc
159
+
txt Location.Compat.print_loc loc
160
160
in
161
161
Format.printf "@[<hov 2>%a:@ %a@]@;"
162
162
Shape.Uid.print uid
···
179
179
printf "Globals defined:\n";
180
180
Symtable.iter_global_map
181
181
(fun global _ ->
182
-
print_line
183
-
(Format.asprintf "%a" Symtable.Global.description global)
182
+
let desc = Format_doc.compat Symtable.Global.description in
183
+
print_line (Format.asprintf "%a" desc global)
184
184
)
185
185
table
186
186
+2
-2
toplevel/byte/topeval.ml
+2
-2
toplevel/byte/topeval.ml
···
164
164
begin match out_phr with
165
165
| Ophr_signature [] -> ()
166
166
| _ ->
167
-
Location.separate_new_message ppf;
167
+
Location.Compat.separate_new_message ppf ();
168
168
!print_out_phrase ppf out_phr;
169
169
end;
170
170
if Printexc.backtrace_status ()
···
172
172
match !backtrace with
173
173
| None -> ()
174
174
| Some b ->
175
-
Location.separate_new_message ppf;
175
+
Location.Compat.separate_new_message ppf ();
176
176
pp_print_string ppf b;
177
177
pp_print_flush ppf ();
178
178
backtrace := None;
+1
toplevel/byte/topmain.ml
+1
toplevel/byte/topmain.ml
+1
toplevel/byte/trace.ml
+1
toplevel/byte/trace.ml
+14
-6
toplevel/genprintval.ml
+14
-6
toplevel/genprintval.ml
···
154
154
] : (Path.t * printer) list)
155
155
156
156
let exn_printer ppf path exn =
157
-
fprintf ppf "<printer %a raised an exception: %s>" Printtyp.path path
157
+
Format_doc.fprintf ppf "<printer %a raised an exception: %s>"
158
+
Printtyp.path path
158
159
(Printexc.to_string exn)
159
160
160
161
let out_exn path exn =
161
162
Oval_printer (fun ppf -> exn_printer ppf path exn)
162
163
164
+
let user_printer path f ppf x =
165
+
Format_doc.deprecated_printer
166
+
(fun ppf ->
167
+
try f ppf x with
168
+
| exn -> Format_doc.compat (fun ppf -> exn_printer ppf path) ppf exn
169
+
)
170
+
ppf
171
+
163
172
let install_printer path ty fn =
164
-
let print_val ppf obj =
165
-
try fn ppf obj with exn -> exn_printer ppf path exn in
173
+
let print_val ppf obj = user_printer path fn ppf obj in
166
174
let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
167
175
printers := (path, Simple (ty, printer)) :: !printers
168
176
···
174
182
match gp with
175
183
| Zero fn ->
176
184
let out_printer obj =
177
-
let printer ppf =
178
-
try fn ppf obj with exn -> exn_printer ppf function_path exn in
185
+
let printer ppf = user_printer function_path fn ppf obj in
179
186
Oval_printer printer in
180
187
Zero out_printer
181
188
| Succ fn ->
···
616
623
| _ ->
617
624
(fun _obj ->
618
625
let printer ppf =
619
-
fprintf ppf "<internal error: incorrect arity for '%a'>"
626
+
Format_doc.fprintf ppf
627
+
"<internal error: incorrect arity for '%a'>"
620
628
Printtyp.path path in
621
629
Oval_printer printer)
622
630
+1
-1
toplevel/native/topeval.ml
+1
-1
toplevel/native/topeval.ml
+12
-10
toplevel/topcommon.ml
+12
-10
toplevel/topcommon.ml
···
28
28
29
29
let parse_toplevel_phrase = ref Parse.toplevel_phrase
30
30
let parse_use_file = ref Parse.use_file
31
-
let print_location = Location.print_loc
31
+
let print_location = Location.Compat.print_loc
32
32
let print_error = Location.print_report
33
33
let print_warning = Location.print_warning
34
34
let input_name = Location.input_name
···
340
340
Hashtbl.fold (fun dir _ acc -> dir::acc) directive_table []
341
341
342
342
module Style = Misc.Style
343
+
let inline_code = Format_doc.compat Style.inline_code
343
344
344
345
let try_run_directive ppf dir_name pdir_arg =
345
346
begin match get_directive dir_name with
346
347
| None ->
347
-
fprintf ppf "Unknown directive %a." Style.inline_code dir_name;
348
+
fprintf ppf "Unknown directive %a." inline_code dir_name;
348
349
let directives = all_directive_names () in
349
-
Misc.did_you_mean ppf
350
+
Format_doc.compat Misc.did_you_mean ppf
350
351
(fun () -> Misc.spellcheck directives dir_name);
351
352
fprintf ppf "@.";
352
353
false
···
360
361
| exception _ ->
361
362
fprintf ppf "Integer literal exceeds the range of \
362
363
representable integers for directive %a.@."
363
-
Style.inline_code dir_name;
364
+
inline_code dir_name;
364
365
false
365
366
end
366
367
| Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} ->
367
368
fprintf ppf "Wrong integer literal for directive %a.@."
368
-
Style.inline_code dir_name;
369
+
inline_code dir_name;
369
370
false
370
371
| Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true
371
372
| Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true
···
387
388
let pp_type ppf = function
388
389
| `None -> Format.fprintf ppf "no argument"
389
390
| `String ->
390
-
Format.fprintf ppf "a %a literal" Style.inline_code "string"
391
+
Format.fprintf ppf "a %a literal" inline_code "string"
391
392
| `Int ->
392
-
Format.fprintf ppf "an %a literal" Style.inline_code "string"
393
+
Format.fprintf ppf "an %a literal" inline_code "string"
393
394
| `Ident ->
394
395
Format.fprintf ppf "an identifier"
395
396
| `Bool ->
396
-
Format.fprintf ppf "a %a literal" Style.inline_code "bool"
397
+
Format.fprintf ppf "a %a literal" inline_code "bool"
397
398
in
398
399
fprintf ppf "Directive %a expects %a, got %a.@."
399
-
Style.inline_code dir_name pp_type dir_type pp_type arg_type;
400
+
inline_code dir_name pp_type dir_type pp_type arg_type;
400
401
false
401
402
end
402
403
403
404
(* Overriding exception printers with toplevel-specific ones *)
404
405
405
406
let loading_hint_printer ppf cu =
407
+
let open Format_doc in
406
408
let global = Symtable.Global.Glob_compunit (Cmo_format.Compunit cu) in
407
409
Symtable.report_error ppf (Symtable.Undefined_global global);
408
410
let find_with_ext ext =
···
417
419
But very often they do. *)
418
420
begin match List.find_map find_with_ext [".cma"; ".cmo"] with
419
421
| Some path ->
420
-
let load ppf path = Format.fprintf ppf "#load \"%s\"" path in
422
+
let load ppf path = Format_doc.fprintf ppf "#load \"%s\"" path in
421
423
fprintf ppf
422
424
"Found %a @,in the load paths. \
423
425
@,Did you mean to load it using @,%a \
+8
-12
toplevel/topcommon.mli
+8
-12
toplevel/topcommon.mli
···
59
59
val max_printer_depth: int ref
60
60
val max_printer_steps: int ref
61
61
62
+
type 'a printer := 'a Oprint.printer
63
+
62
64
val print_out_value :
63
65
(formatter -> Outcometree.out_value -> unit) ref
64
-
val print_out_type :
65
-
(formatter -> Outcometree.out_type -> unit) ref
66
-
val print_out_class_type :
67
-
(formatter -> Outcometree.out_class_type -> unit) ref
68
-
val print_out_module_type :
69
-
(formatter -> Outcometree.out_module_type -> unit) ref
70
-
val print_out_type_extension :
71
-
(formatter -> Outcometree.out_type_extension -> unit) ref
72
-
val print_out_sig_item :
73
-
(formatter -> Outcometree.out_sig_item -> unit) ref
74
-
val print_out_signature :
75
-
(formatter -> Outcometree.out_sig_item list -> unit) ref
66
+
val print_out_type : Outcometree.out_type printer
67
+
val print_out_class_type : Outcometree.out_class_type printer
68
+
val print_out_module_type : Outcometree.out_module_type printer
69
+
val print_out_type_extension : Outcometree.out_type_extension printer
70
+
val print_out_sig_item : Outcometree.out_sig_item printer
71
+
val print_out_signature : Outcometree.out_sig_item list printer
76
72
val print_out_phrase :
77
73
(formatter -> Outcometree.out_phrase -> unit) ref
78
74
+5
-5
toplevel/topdirs.ml
+5
-5
toplevel/topdirs.ml
···
289
289
| exception Not_found ->
290
290
let report ppf =
291
291
fprintf ppf "Unbound value %a.@."
292
-
Printtyp.longident lid
292
+
Printtyp.Compat.longident lid
293
293
in Error report
294
294
| (path, desc) ->
295
295
match match_printer_type desc with
296
296
| None ->
297
297
let report ppf =
298
298
fprintf ppf "%a has the wrong type for a printing function.@."
299
-
Printtyp.longident lid
299
+
Printtyp.Compat.longident lid
300
300
in Error report
301
301
| Some kind -> Ok (path, kind)
302
302
···
325
325
| exception Not_found ->
326
326
let report ppf =
327
327
fprintf ppf "The printer named %a is not installed.@."
328
-
Printtyp.path path
328
+
Printtyp.Compat.path path
329
329
in Error report
330
330
331
331
let dir_install_printer ppf lid =
···
393
393
| Longident.Lident s -> s
394
394
| Longident.Ldot (_,s) -> s
395
395
| Longident.Lapply _ ->
396
-
fprintf ppf "Invalid path %a@." Printtyp.longident lid;
396
+
fprintf ppf "Invalid path %a@." Printtyp.Compat.longident lid;
397
397
raise Exit
398
398
in
399
399
let id = Ident.create_persistent s in
400
400
let sg = to_sig env loc id lid in
401
401
Printtyp.wrap_printing_env ~error:false env
402
-
(fun () -> fprintf ppf "@[%a@]@." Printtyp.signature sg)
402
+
(fun () -> fprintf ppf "@[%a@]@." Printtyp.Compat.signature sg)
403
403
with
404
404
| Not_found ->
405
405
fprintf ppf "@[Unknown element.@]@."
+1
-1
toplevel/toploop.ml
+1
-1
toplevel/toploop.ml
···
388
388
Config.version
389
389
(if Topeval.implementation_label = "" then "" else " - ")
390
390
Topeval.implementation_label
391
-
Misc.Style.inline_code "#help;;";
391
+
(Format_doc.compat Misc.Style.inline_code) "#help;;";
392
392
let lb = Lexing.from_function refill_lexbuf in
393
393
Location.init lb "//toplevel//";
394
394
Location.input_name := "//toplevel//";
+8
-12
toplevel/toploop.mli
+8
-12
toplevel/toploop.mli
···
144
144
145
145
val print_out_value :
146
146
(formatter -> Outcometree.out_value -> unit) ref
147
-
val print_out_type :
148
-
(formatter -> Outcometree.out_type -> unit) ref
149
-
val print_out_class_type :
150
-
(formatter -> Outcometree.out_class_type -> unit) ref
151
-
val print_out_module_type :
152
-
(formatter -> Outcometree.out_module_type -> unit) ref
153
-
val print_out_type_extension :
154
-
(formatter -> Outcometree.out_type_extension -> unit) ref
155
-
val print_out_sig_item :
156
-
(formatter -> Outcometree.out_sig_item -> unit) ref
157
-
val print_out_signature :
158
-
(formatter -> Outcometree.out_sig_item list -> unit) ref
147
+
148
+
type 'a oprinter := 'a Oprint.printer
149
+
val print_out_type : Outcometree.out_type oprinter
150
+
val print_out_class_type : Outcometree.out_class_type oprinter
151
+
val print_out_module_type : Outcometree.out_module_type oprinter
152
+
val print_out_type_extension : Outcometree.out_type_extension oprinter
153
+
val print_out_sig_item : Outcometree.out_sig_item oprinter
154
+
val print_out_signature : Outcometree.out_sig_item list oprinter
159
155
val print_out_phrase :
160
156
(formatter -> Outcometree.out_phrase -> unit) ref
161
157
+2
-1
typing/ctype.ml
+2
-1
typing/ctype.ml
···
119
119
exception Tags of label * label
120
120
121
121
let () =
122
+
let open Format_doc in
122
123
Location.register_error_of_exn
123
124
(function
124
125
| Tags (l, l') ->
125
-
let pp_tag ppf s = Format.fprintf ppf "`%s" s in
126
+
let pp_tag ppf s = fprintf ppf "`%s" s in
126
127
let inline_tag = Misc.Style.as_inline_code pp_tag in
127
128
Some
128
129
Location.
+29
-27
typing/env.ml
+29
-27
typing/env.ml
···
3512
3512
3513
3513
(* Error report *)
3514
3514
3515
-
open Format
3515
+
open Format_doc
3516
3516
3517
3517
(* Forward declarations *)
3518
3518
3519
-
let print_longident =
3520
-
ref ((fun _ _ -> assert false) : formatter -> Longident.t -> unit)
3519
+
let print_longident : Longident.t printer ref = ref (fun _ _ -> assert false)
3520
+
3521
+
let pp_longident ppf l = !print_longident ppf l
3521
3522
3522
-
let print_path =
3523
-
ref ((fun _ _ -> assert false) : formatter -> Path.t -> unit)
3523
+
let print_path: Path.t printer ref = ref (fun _ _ -> assert false)
3524
+
let pp_path ppf l = !print_path ppf l
3524
3525
3525
3526
let spellcheck ppf extract env lid =
3526
3527
let choices ~path name = Misc.spellcheck (extract path env) name in
···
3560
3561
3561
3562
module Style = Misc.Style
3562
3563
3564
+
let quoted_longident = Style.as_inline_code pp_longident
3565
+
3563
3566
let report_lookup_error _loc env ppf = function
3564
3567
| Unbound_value(lid, hint) -> begin
3565
-
fprintf ppf "Unbound value %a"
3566
-
(Style.as_inline_code !print_longident) lid;
3568
+
fprintf ppf "Unbound value %a" quoted_longident lid;
3567
3569
spellcheck ppf extract_values env lid;
3568
3570
match hint with
3569
3571
| No_hint -> ()
···
3579
3581
end
3580
3582
| Unbound_type lid ->
3581
3583
fprintf ppf "Unbound type constructor %a"
3582
-
(Style.as_inline_code !print_longident) lid;
3584
+
quoted_longident lid;
3583
3585
spellcheck ppf extract_types env lid;
3584
3586
| Unbound_module lid -> begin
3585
3587
fprintf ppf "Unbound module %a"
3586
-
(Style.as_inline_code !print_longident) lid;
3588
+
quoted_longident lid;
3587
3589
match find_modtype_by_name lid env with
3588
3590
| exception Not_found -> spellcheck ppf extract_modules env lid;
3589
3591
| _ ->
3590
3592
fprintf ppf
3591
3593
"@.@[@{<hint>Hint@}: There is a module type named %a, %s@]"
3592
-
(Style.as_inline_code !print_longident) lid
3594
+
quoted_longident lid
3593
3595
"but module types are not modules"
3594
3596
end
3595
3597
| Unbound_constructor lid ->
3596
3598
fprintf ppf "Unbound constructor %a"
3597
-
(Style.as_inline_code !print_longident) lid;
3599
+
quoted_longident lid;
3598
3600
spellcheck ppf extract_constructors env lid;
3599
3601
| Unbound_label lid ->
3600
3602
fprintf ppf "Unbound record field %a"
3601
-
(Style.as_inline_code !print_longident) lid;
3603
+
quoted_longident lid;
3602
3604
spellcheck ppf extract_labels env lid;
3603
3605
| Unbound_class lid -> begin
3604
3606
fprintf ppf "Unbound class %a"
3605
-
(Style.as_inline_code !print_longident) lid;
3607
+
quoted_longident lid;
3606
3608
match find_cltype_by_name lid env with
3607
3609
| exception Not_found -> spellcheck ppf extract_classes env lid;
3608
3610
| _ ->
3609
3611
fprintf ppf
3610
3612
"@.@[@{<hint>Hint@}: There is a class type named %a, %s@]"
3611
-
(Style.as_inline_code !print_longident) lid
3613
+
quoted_longident lid
3612
3614
"but classes are not class types"
3613
3615
end
3614
3616
| Unbound_modtype lid -> begin
3615
3617
fprintf ppf "Unbound module type %a"
3616
-
(Style.as_inline_code !print_longident) lid;
3618
+
quoted_longident lid;
3617
3619
match find_module_by_name lid env with
3618
3620
| exception Not_found -> spellcheck ppf extract_modtypes env lid;
3619
3621
| _ ->
3620
3622
fprintf ppf
3621
3623
"@.@[@{<hint>Hint@}: There is a module named %a, %s@]"
3622
-
(Style.as_inline_code !print_longident) lid
3624
+
quoted_longident lid
3623
3625
"but modules are not module types"
3624
3626
end
3625
3627
| Unbound_cltype lid ->
3626
3628
fprintf ppf "Unbound class type %a"
3627
-
(Style.as_inline_code !print_longident) lid;
3629
+
quoted_longident lid;
3628
3630
spellcheck ppf extract_cltypes env lid;
3629
3631
| Unbound_instance_variable s ->
3630
3632
fprintf ppf "Unbound instance variable %a" Style.inline_code s;
···
3637
3639
fprintf ppf
3638
3640
"The instance variable %a@ \
3639
3641
cannot be accessed from the definition of another instance variable"
3640
-
(Style.as_inline_code !print_longident) lid
3642
+
quoted_longident lid
3641
3643
| Masked_self_variable lid ->
3642
3644
fprintf ppf
3643
3645
"The self variable %a@ \
3644
3646
cannot be accessed from the definition of an instance variable"
3645
-
(Style.as_inline_code !print_longident) lid
3647
+
quoted_longident lid
3646
3648
| Masked_ancestor_variable lid ->
3647
3649
fprintf ppf
3648
3650
"The ancestor variable %a@ \
3649
3651
cannot be accessed from the definition of an instance variable"
3650
-
(Style.as_inline_code !print_longident) lid
3652
+
quoted_longident lid
3651
3653
| Illegal_reference_to_recursive_module ->
3652
3654
fprintf ppf "Illegal recursive module reference"
3653
3655
| Structure_used_as_functor lid ->
3654
3656
fprintf ppf "@[The module %a is a structure, it cannot be applied@]"
3655
-
(Style.as_inline_code !print_longident) lid
3657
+
quoted_longident lid
3656
3658
| Abstract_used_as_functor lid ->
3657
3659
fprintf ppf "@[The module %a is abstract, it cannot be applied@]"
3658
-
(Style.as_inline_code !print_longident) lid
3660
+
quoted_longident lid
3659
3661
| Functor_used_as_structure lid ->
3660
3662
fprintf ppf "@[The module %a is a functor, \
3661
-
it cannot have any components@]" !print_longident lid
3663
+
it cannot have any components@]" pp_longident lid
3662
3664
| Abstract_used_as_structure lid ->
3663
3665
fprintf ppf "@[The module %a is abstract, \
3664
3666
it cannot have any components@]"
3665
-
(Style.as_inline_code !print_longident) lid
3667
+
quoted_longident lid
3666
3668
| Generative_used_as_applicative lid ->
3667
3669
fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \
3668
3670
applied@ in@ type@ expressions@]"
3669
-
(Style.as_inline_code !print_longident) lid
3671
+
quoted_longident lid
3670
3672
| Cannot_scrape_alias(lid, p) ->
3671
3673
let cause =
3672
3674
if Current_unit_name.is_path p then "is the current compilation unit"
···
3674
3676
in
3675
3677
fprintf ppf
3676
3678
"The module %a is an alias for module %a, which %s"
3677
-
(Style.as_inline_code !print_longident) lid
3678
-
(Style.as_inline_code !print_path) p cause
3679
+
quoted_longident lid
3680
+
(Style.as_inline_code pp_path) p cause
3679
3681
3680
3682
let report_error ppf = function
3681
3683
| Missing_module(_, path1, path2) ->
+4
-6
typing/env.mli
+4
-6
typing/env.mli
···
447
447
448
448
exception Error of error
449
449
450
-
open Format
451
-
452
-
val report_error: formatter -> error -> unit
453
450
454
-
val report_lookup_error: Location.t -> t -> formatter -> lookup_error -> unit
451
+
val report_error: error Format_doc.printer
455
452
453
+
val report_lookup_error: Location.t -> t -> lookup_error Format_doc.printer
456
454
val in_signature: bool -> t -> t
457
455
458
456
val is_in_signature: t -> bool
···
482
480
(* Forward declaration to break mutual recursion with Ctype. *)
483
481
val same_constr: (t -> type_expr -> type_expr -> bool) ref
484
482
(* Forward declaration to break mutual recursion with Printtyp. *)
485
-
val print_longident: (Format.formatter -> Longident.t -> unit) ref
483
+
val print_longident: Longident.t Format_doc.printer ref
486
484
(* Forward declaration to break mutual recursion with Printtyp. *)
487
-
val print_path: (Format.formatter -> Path.t -> unit) ref
485
+
val print_path: Path.t Format_doc.printer ref
488
486
489
487
490
488
(** Folds *)
+1
-1
typing/envaux.ml
+1
-1
typing/envaux.ml
+1
-3
typing/envaux.mli
+1
-3
typing/envaux.mli
···
14
14
(* *)
15
15
(**************************************************************************)
16
16
17
-
open Format
18
-
19
17
(* Convert environment summaries to environments *)
20
18
21
19
val env_from_summary : Env.summary -> Subst.t -> Env.t
···
33
31
34
32
exception Error of error
35
33
36
-
val report_error: formatter -> error -> unit
34
+
val report_error: error Format_doc.printer
+3
-3
typing/errortrace.ml
+3
-3
typing/errortrace.ml
···
16
16
(**************************************************************************)
17
17
18
18
open Types
19
-
open Format
19
+
open Format_doc
20
20
21
21
type position = First | Second
22
22
···
100
100
101
101
type first_class_module =
102
102
| Package_cannot_scrape of Path.t
103
-
| Package_inclusion of (Format.formatter -> unit)
104
-
| Package_coercion of (Format.formatter -> unit)
103
+
| Package_inclusion of Format_doc.doc
104
+
| Package_coercion of Format_doc.doc
105
105
106
106
type ('a, 'variety) elt =
107
107
(* Common *)
+3
-3
typing/errortrace.mli
+3
-3
typing/errortrace.mli
···
20
20
type position = First | Second
21
21
22
22
val swap_position : position -> position
23
-
val print_pos : Format.formatter -> position -> unit
23
+
val print_pos : position Format_doc.printer
24
24
25
25
type expanded_type = { ty: type_expr; expanded: type_expr }
26
26
···
86
86
87
87
type first_class_module =
88
88
| Package_cannot_scrape of Path.t
89
-
| Package_inclusion of (Format.formatter -> unit)
90
-
| Package_coercion of (Format.formatter -> unit)
89
+
| Package_inclusion of Format_doc.doc
90
+
| Package_coercion of Format_doc.doc
91
91
92
92
type ('a, 'variety) elt =
93
93
(* Common *)
+7
-7
typing/ident.ml
+7
-7
typing/ident.ml
···
138
138
| _ -> false
139
139
140
140
let print ~with_scope ppf =
141
-
let open Format in
141
+
let open Format_doc in
142
142
function
143
143
| Global name -> fprintf ppf "%s!" name
144
144
| Predef { name; stamp = n } ->
145
145
fprintf ppf "%s%s!" name
146
-
(if !Clflags.unique_ids then sprintf "/%i" n else "")
146
+
(if !Clflags.unique_ids then asprintf "/%i" n else "")
147
147
| Local { name; stamp = n } ->
148
148
fprintf ppf "%s%s" name
149
-
(if !Clflags.unique_ids then sprintf "/%i" n else "")
149
+
(if !Clflags.unique_ids then asprintf "/%i" n else "")
150
150
| Scoped { name; stamp = n; scope } ->
151
151
fprintf ppf "%s%s%s" name
152
-
(if !Clflags.unique_ids then sprintf "/%i" n else "")
153
-
(if with_scope then sprintf "[%i]" scope else "")
152
+
(if !Clflags.unique_ids then asprintf "/%i" n else "")
153
+
(if with_scope then asprintf "[%i]" scope else "")
154
154
155
155
let print_with_scope ppf id = print ~with_scope:true ppf id
156
156
157
-
let print ppf id = print ~with_scope:false ppf id
158
-
157
+
let doc_print ppf id = print ~with_scope:false ppf id
158
+
let print ppf id = Format_doc.compat doc_print ppf id
159
159
(* For the documentation of ['a Ident.tbl], see ident.mli.
160
160
161
161
The implementation is a copy-paste specialization of
+2
-1
typing/ident.mli
+2
-1
typing/ident.mli
···
24
24
- [compare] compares identifiers by binding location
25
25
*)
26
26
27
-
val print_with_scope : Format.formatter -> t -> unit
27
+
val doc_print: t Format_doc.printer
28
+
val print_with_scope : t Format_doc.printer
28
29
(** Same as {!print} except that it will also add a "[n]" suffix
29
30
if the scope of the argument is [n]. *)
30
31
+10
-17
typing/includeclass.ml
+10
-17
typing/includeclass.ml
···
40
40
cty1.cty_params cty1.cty_type
41
41
cty2.cty_params cty2.cty_type
42
42
43
-
open Format
43
+
open Format_doc
44
44
open Ctype
45
45
46
46
(*
···
50
50
*)
51
51
52
52
let include_err mode ppf =
53
+
let msg fmt = Format_doc.Core.msg fmt in
53
54
function
54
55
| CM_Virtual_class ->
55
56
fprintf ppf "A class cannot be changed from virtual to concrete"
···
58
59
"The classes do not have the same number of type parameters"
59
60
| CM_Type_parameter_mismatch (n, env, err) ->
60
61
Printtyp.report_equality_error ppf mode env err
61
-
(function ppf ->
62
-
fprintf ppf "The %d%s type parameter has type"
62
+
(msg "The %d%s type parameter has type"
63
63
n (Misc.ordinal_suffix n))
64
-
(function ppf ->
65
-
fprintf ppf "but is expected to have type")
64
+
(msg "but is expected to have type")
66
65
| CM_Class_type_mismatch (env, cty1, cty2) ->
67
66
Printtyp.wrap_printing_env ~error:true env (fun () ->
68
67
fprintf ppf
···
72
71
Printtyp.class_type cty2)
73
72
| CM_Parameter_mismatch (n, env, err) ->
74
73
Printtyp.report_moregen_error ppf mode env err
75
-
(function ppf ->
76
-
fprintf ppf "The %d%s parameter has type"
74
+
(msg "The %d%s parameter has type"
77
75
n (Misc.ordinal_suffix n))
78
-
(function ppf ->
79
-
fprintf ppf "but is expected to have type")
76
+
(msg "but is expected to have type")
80
77
| CM_Val_type_mismatch (lab, env, err) ->
81
78
Printtyp.report_comparison_error ppf mode env err
82
-
(function ppf ->
83
-
fprintf ppf "The instance variable %s@ has type" lab)
84
-
(function ppf ->
85
-
fprintf ppf "but is expected to have type")
79
+
(msg "The instance variable %s@ has type" lab)
80
+
(msg "but is expected to have type")
86
81
| CM_Meth_type_mismatch (lab, env, err) ->
87
82
Printtyp.report_comparison_error ppf mode env err
88
-
(function ppf ->
89
-
fprintf ppf "The method %s@ has type" lab)
90
-
(function ppf ->
91
-
fprintf ppf "but is expected to have type")
83
+
(msg "The method %s@ has type" lab)
84
+
(msg "but is expected to have type")
92
85
| CM_Non_mutable_value lab ->
93
86
fprintf ppf
94
87
"@[The non-mutable instance variable %s cannot become mutable@]" lab
+1
-2
typing/includeclass.mli
+1
-2
typing/includeclass.mli
···
17
17
18
18
open Types
19
19
open Ctype
20
-
open Format
21
20
22
21
val class_types:
23
22
Env.t -> class_type -> class_type -> class_match_failure list
···
30
29
class_match_failure list
31
30
32
31
val report_error :
33
-
Printtyp.type_or_scheme -> formatter -> class_match_failure list -> unit
32
+
Printtyp.type_or_scheme -> class_match_failure list Format_doc.printer
+35
-32
typing/includecore.ml
+35
-32
typing/includecore.ml
···
208
208
| Immediate of Type_immediacy.Violation.t
209
209
210
210
module Style = Misc.Style
211
+
module Fmt = Format_doc
211
212
212
213
let report_primitive_mismatch first second ppf err =
213
-
let pr fmt = Format.fprintf ppf fmt in
214
+
let pr fmt = Fmt.fprintf ppf fmt in
214
215
match (err : primitive_mismatch) with
215
216
| Name ->
216
217
pr "The names of the primitives are not the same"
···
231
232
n (Misc.ordinal_suffix n)
232
233
233
234
let report_value_mismatch first second env ppf err =
234
-
let pr fmt = Format.fprintf ppf fmt in
235
+
let pr fmt = Fmt.fprintf ppf fmt in
235
236
pr "@ ";
236
237
match (err : value_mismatch) with
237
238
| Primitive_mismatch pm ->
···
239
240
| Not_a_primitive ->
240
241
pr "The implementation is not a primitive."
241
242
| Type trace ->
243
+
let msg = Fmt.Core.msg in
242
244
Printtyp.report_moregen_error ppf Type_scheme env trace
243
-
(fun ppf -> Format.fprintf ppf "The type")
244
-
(fun ppf -> Format.fprintf ppf "is not compatible with the type")
245
+
(msg "The type")
246
+
(msg "is not compatible with the type")
245
247
246
248
let report_type_inequality env ppf err =
249
+
let msg = Fmt.Core.msg in
247
250
Printtyp.report_equality_error ppf Type_scheme env err
248
-
(fun ppf -> Format.fprintf ppf "The type")
249
-
(fun ppf -> Format.fprintf ppf "is not equal to the type")
251
+
(msg "The type")
252
+
(msg "is not equal to the type")
250
253
251
254
let report_privacy_mismatch ppf err =
252
255
let singular, item =
···
256
259
| Private_record_type -> true, "record constructor"
257
260
| Private_extensible_variant -> true, "extensible variant"
258
261
| Private_row_type -> true, "row type"
259
-
in Format.fprintf ppf "%s %s would be revealed."
262
+
in Format_doc.fprintf ppf "%s %s would be revealed."
260
263
(if singular then "A private" else "Private")
261
264
item
262
265
···
265
268
| Type err ->
266
269
report_type_inequality env ppf err
267
270
| Mutability ord ->
268
-
Format.fprintf ppf "%s is mutable and %s is not."
271
+
Format_doc.fprintf ppf "%s is mutable and %s is not."
269
272
(String.capitalize_ascii (choose ord first second))
270
273
(choose_other ord first second)
271
274
272
275
let pp_record_diff first second prefix decl env ppf (x : record_change) =
273
276
match x with
274
277
| Delete cd ->
275
-
Format.fprintf ppf "%aAn extra field, %a, is provided in %s %s."
278
+
Fmt.fprintf ppf "%aAn extra field, %a, is provided in %s %s."
276
279
prefix x Style.inline_code (Ident.name cd.delete.ld_id) first decl
277
280
| Insert cd ->
278
-
Format.fprintf ppf "%aA field, %a, is missing in %s %s."
281
+
Fmt.fprintf ppf "%aA field, %a, is missing in %s %s."
279
282
prefix x Style.inline_code (Ident.name cd.insert.ld_id) first decl
280
283
| Change Type {got=lbl1; expected=lbl2; reason} ->
281
-
Format.fprintf ppf
284
+
Fmt.fprintf ppf
282
285
"@[<hv>%aFields do not match:@;<1 2>\
283
286
%a@ is not the same as:\
284
287
@;<1 2>%a@ %a@]"
···
287
290
(Style.as_inline_code Printtyp.label) lbl2
288
291
(report_label_mismatch first second env) reason
289
292
| Change Name n ->
290
-
Format.fprintf ppf "%aFields have different names, %a and %a."
293
+
Fmt.fprintf ppf "%aFields have different names, %a and %a."
291
294
prefix x
292
295
Style.inline_code n.got
293
296
Style.inline_code n.expected
294
297
| Swap sw ->
295
-
Format.fprintf ppf "%aFields %a and %a have been swapped."
298
+
Fmt.fprintf ppf "%aFields %a and %a have been swapped."
296
299
prefix x
297
300
Style.inline_code sw.first
298
301
Style.inline_code sw.last
299
302
| Move {name; got; expected } ->
300
-
Format.fprintf ppf
303
+
Fmt.fprintf ppf
301
304
"@[<2>%aField %a has been moved@ from@ position %d@ to %d.@]"
302
305
prefix x Style.inline_code name expected got
303
306
304
307
let report_patch pr_diff first second decl env ppf patch =
305
-
let nl ppf () = Format.fprintf ppf "@," in
308
+
let nl ppf () = Fmt.fprintf ppf "@," in
306
309
let no_prefix _ppf _ = () in
307
310
match patch with
308
311
| [ elt ] ->
309
-
Format.fprintf ppf "@[<hv>%a@]"
312
+
Fmt.fprintf ppf "@[<hv>%a@]"
310
313
(pr_diff first second no_prefix decl env) elt
311
314
| _ ->
312
315
let pp_diff = pr_diff first second Diffing_with_keys.prefix decl env in
313
-
Format.fprintf ppf "@[<hv>%a@]"
314
-
(Format.pp_print_list ~pp_sep:nl pp_diff) patch
316
+
Fmt.fprintf ppf "@[<hv>%a@]"
317
+
(Fmt.pp_print_list ~pp_sep:nl pp_diff) patch
315
318
316
319
let report_record_mismatch first second decl env ppf err =
317
-
let pr fmt = Format.fprintf ppf fmt in
320
+
let pr fmt = Fmt.fprintf ppf fmt in
318
321
match err with
319
322
| Label_mismatch patch ->
320
323
report_patch pp_record_diff first second decl env ppf patch
···
324
327
"uses unboxed float representation"
325
328
326
329
let report_constructor_mismatch first second decl env ppf err =
327
-
let pr fmt = Format.fprintf ppf fmt in
330
+
let pr fmt = Fmt.fprintf ppf fmt in
328
331
match (err : constructor_mismatch) with
329
332
| Type err -> report_type_inequality env ppf err
330
333
| Arity -> pr "They have different arities."
···
342
345
let pp_variant_diff first second prefix decl env ppf (x : variant_change) =
343
346
match x with
344
347
| Delete cd ->
345
-
Format.fprintf ppf "%aAn extra constructor, %a, is provided in %s %s."
348
+
Fmt.fprintf ppf "%aAn extra constructor, %a, is provided in %s %s."
346
349
prefix x Style.inline_code (Ident.name cd.delete.cd_id) first decl
347
350
| Insert cd ->
348
-
Format.fprintf ppf "%aA constructor, %a, is missing in %s %s."
351
+
Fmt.fprintf ppf "%aA constructor, %a, is missing in %s %s."
349
352
prefix x Style.inline_code (Ident.name cd.insert.cd_id) first decl
350
353
| Change Type {got; expected; reason} ->
351
-
Format.fprintf ppf
354
+
Fmt.fprintf ppf
352
355
"@[<hv>%aConstructors do not match:@;<1 2>\
353
356
%a@ is not the same as:\
354
357
@;<1 2>%a@ %a@]"
···
357
360
(Style.as_inline_code Printtyp.constructor) expected
358
361
(report_constructor_mismatch first second decl env) reason
359
362
| Change Name n ->
360
-
Format.fprintf ppf
363
+
Fmt.fprintf ppf
361
364
"%aConstructors have different names, %a and %a."
362
365
prefix x
363
366
Style.inline_code n.got
364
367
Style.inline_code n.expected
365
368
| Swap sw ->
366
-
Format.fprintf ppf
369
+
Fmt.fprintf ppf
367
370
"%aConstructors %a and %a have been swapped."
368
371
prefix x
369
372
Style.inline_code sw.first
370
373
Style.inline_code sw.last
371
374
| Move {name; got; expected} ->
372
-
Format.fprintf ppf
375
+
Fmt.fprintf ppf
373
376
"@[<2>%aConstructor %a has been moved@ from@ position %d@ to %d.@]"
374
377
prefix x Style.inline_code name expected got
375
378
376
379
let report_extension_constructor_mismatch first second decl env ppf err =
377
-
let pr fmt = Format.fprintf ppf fmt in
380
+
let pr fmt = Fmt.fprintf ppf fmt in
378
381
match (err : extension_constructor_mismatch) with
379
382
| Constructor_privacy ->
380
383
pr "Private extension constructor(s) would be revealed."
···
390
393
391
394
392
395
let report_private_variant_mismatch first second decl env ppf err =
393
-
let pr fmt = Format.fprintf ppf fmt in
394
-
let pp_tag ppf x = Format.fprintf ppf "`%s" x in
396
+
let pr fmt = Fmt.fprintf ppf fmt in
397
+
let pp_tag ppf x = Fmt.fprintf ppf "`%s" x in
395
398
match (err : private_variant_mismatch) with
396
399
| Only_outer_closed ->
397
400
(* It's only dangerous in one direction, so we don't have a position *)
···
408
411
report_type_inequality env ppf err
409
412
410
413
let report_private_object_mismatch env ppf err =
411
-
let pr fmt = Format.fprintf ppf fmt in
414
+
let pr fmt = Fmt.fprintf ppf fmt in
412
415
match (err : private_object_mismatch) with
413
416
| Missing s ->
414
417
pr "The implementation is missing the method %a" Style.inline_code s
415
418
| Types err -> report_type_inequality env ppf err
416
419
417
420
let report_kind_mismatch first second ppf (kind1, kind2) =
418
-
let pr fmt = Format.fprintf ppf fmt in
421
+
let pr fmt = Fmt.fprintf ppf fmt in
419
422
let kind_to_string = function
420
423
| Kind_abstract -> "abstract"
421
424
| Kind_record -> "a record"
···
428
431
(kind_to_string kind2)
429
432
430
433
let report_type_mismatch first second decl env ppf err =
431
-
let pr fmt = Format.fprintf ppf fmt in
434
+
let pr fmt = Fmt.fprintf ppf fmt in
432
435
pr "@ ";
433
436
match err with
434
437
| Arity ->
+3
-3
typing/includecore.mli
+3
-3
typing/includecore.mli
···
141
141
val report_value_mismatch :
142
142
string -> string ->
143
143
Env.t ->
144
-
Format.formatter -> value_mismatch -> unit
144
+
value_mismatch Format_doc.printer
145
145
146
146
val report_type_mismatch :
147
147
string -> string -> string ->
148
148
Env.t ->
149
-
Format.formatter -> type_mismatch -> unit
149
+
type_mismatch Format_doc.printer
150
150
151
151
val report_extension_constructor_mismatch :
152
152
string -> string -> string ->
153
153
Env.t ->
154
-
Format.formatter -> extension_constructor_mismatch -> unit
154
+
extension_constructor_mismatch Format_doc.printer
+1
-1
typing/includemod.ml
+1
-1
typing/includemod.ml
+91
-91
typing/includemod_errorprinter.ml
+91
-91
typing/includemod_errorprinter.ml
···
14
14
(**************************************************************************)
15
15
16
16
module Style = Misc.Style
17
+
module Fmt = Format_doc
17
18
18
19
module Context = struct
19
20
type pos =
···
34
35
35
36
let rec context ppf = function
36
37
Module id :: rem ->
37
-
Format.fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem
38
+
Fmt.fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem
38
39
| Modtype id :: rem ->
39
-
Format.fprintf ppf "@[<2>module type %a =@ %a@]"
40
+
Fmt.fprintf ppf "@[<2>module type %a =@ %a@]"
40
41
Printtyp.ident id context_mty rem
41
42
| Body x :: rem ->
42
-
Format.fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
43
+
Fmt.fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
43
44
| Arg x :: rem ->
44
-
Format.fprintf ppf "functor (%s : %a) -> ..."
45
+
Fmt.fprintf ppf "functor (%s : %a) -> ..."
45
46
(argname x) context_mty rem
46
47
| [] ->
47
-
Format.fprintf ppf "<here>"
48
+
Fmt.fprintf ppf "<here>"
48
49
and context_mty ppf = function
49
50
(Module _ | Modtype _) :: _ as rem ->
50
-
Format.fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
51
+
Fmt.fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
51
52
| cxt -> context ppf cxt
52
53
and args ppf = function
53
54
Body x :: rem ->
54
-
Format.fprintf ppf "(%s)%a" (argname x) args rem
55
+
Fmt.fprintf ppf "(%s)%a" (argname x) args rem
55
56
| Arg x :: rem ->
56
-
Format.fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem
57
+
Fmt.fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem
57
58
| cxt ->
58
-
Format.fprintf ppf " :@ %a" context_mty cxt
59
+
Fmt.fprintf ppf " :@ %a" context_mty cxt
59
60
and argname = function
60
61
| Types.Unit -> ""
61
62
| Types.Named (None, _) -> "_"
···
64
65
let alt_pp ppf cxt =
65
66
if cxt = [] then () else
66
67
if List.for_all (function Module _ -> true | _ -> false) cxt then
67
-
Format.fprintf ppf ",@ in module %a"
68
+
Fmt.fprintf ppf ",@ in module %a"
68
69
(Style.as_inline_code Printtyp.path) (path_of_context cxt)
69
70
else
70
-
Format.fprintf ppf ",@ @[<hv 2>at position@ %a@]"
71
+
Fmt.fprintf ppf ",@ @[<hv 2>at position@ %a@]"
71
72
(Style.as_inline_code context) cxt
72
73
73
74
let pp ppf cxt =
74
75
if cxt = [] then () else
75
76
if List.for_all (function Module _ -> true | _ -> false) cxt then
76
-
Format.fprintf ppf "In module %a:@ "
77
+
Fmt.fprintf ppf "In module %a:@ "
77
78
(Style.as_inline_code Printtyp.path) (path_of_context cxt)
78
79
else
79
-
Format.fprintf ppf "@[<hv 2>At position@ %a@]@ "
80
+
Fmt.fprintf ppf "@[<hv 2>At position@ %a@]@ "
80
81
(Style.as_inline_code context) cxt
81
82
end
82
83
···
174
175
let item mt k = Includemod.item_ident_name (runtime_item k mt)
175
176
176
177
let pp_item ppf (id,_,kind) =
177
-
Format.fprintf ppf "%s %a"
178
+
Fmt.fprintf ppf "%s %a"
178
179
(Includemod.kind_of_field_desc kind)
179
180
Style.inline_code (Ident.name id)
180
181
···
187
188
| Some (path, Transposition (k,l)) ->
188
189
try
189
190
let ctx, mt = find env path mty in
190
-
Format.fprintf ppf
191
+
Fmt.fprintf ppf
191
192
"@[<hv 2>Illegal permutation of runtime components in a module type.@ \
192
193
@[For example%a,@]@ @[the %a@ and the %a are not in the same order@ \
193
194
in the expected and actual module types.@]@]"
194
195
ctx_printer ctx pp_item (item mt k) pp_item (item mt l)
195
196
with Not_found -> (* this should not happen *)
196
-
Format.fprintf ppf
197
+
Fmt.fprintf ppf
197
198
"Illegal permutation of runtime components in a module type."
198
199
199
200
let in_package_subtype ctx_printer env mty c ppf =
···
202
203
(* The coercion looks like the identity but was not simplified to
203
204
[Tcoerce_none], this only happens when the two first-class module
204
205
types differ by runtime size *)
205
-
Format.fprintf ppf
206
+
Fmt.fprintf ppf
206
207
"The two first-class module types differ by their runtime size."
207
208
| Some (path, c) ->
208
209
try
209
210
let ctx, mt = find env path mty in
210
211
match c with
211
212
| Primitive_coercion prim_name ->
212
-
Format.fprintf ppf
213
+
Fmt.fprintf ppf
213
214
"@[The two first-class module types differ by a coercion of@ \
214
215
the primitive %a@ to a value%a.@]"
215
216
Style.inline_code prim_name
216
217
ctx_printer ctx
217
218
| Alias_coercion path ->
218
-
Format.fprintf ppf
219
+
Fmt.fprintf ppf
219
220
"@[The two first-class module types differ by a coercion of@ \
220
221
a module alias %a@ to a module%a.@]"
221
222
(Style.as_inline_code Printtyp.path) path
222
223
ctx_printer ctx
223
224
| Transposition (k,l) ->
224
-
Format.fprintf ppf
225
+
Fmt.fprintf ppf
225
226
"@[@[The two first-class module types do not share@ \
226
227
the same positions for runtime components.@]@ \
227
228
@[For example,%a@ the %a@ occurs at the expected position of@ \
228
229
the %a.@]@]"
229
230
ctx_printer ctx pp_item (item mt k) pp_item (item mt l)
230
231
with Not_found ->
231
-
Format.fprintf ppf
232
+
Fmt.fprintf ppf
232
233
"@[The two packages types do not share@ \
233
234
the@ same@ positions@ for@ runtime@ components.@]"
234
235
···
251
252
let show_loc msg ppf loc =
252
253
let pos = loc.Location.loc_start in
253
254
if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then ()
254
-
else Format.fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg
255
+
else Fmt.fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg
255
256
256
257
let show_locs ppf (loc1, loc2) =
257
258
show_loc "Expected declaration" ppf loc2;
···
260
261
261
262
let dmodtype mty =
262
263
let tmty = Printtyp.tree_of_modtype mty in
263
-
Format.dprintf "%a" !Oprint.out_module_type tmty
264
+
Fmt.dprintf "%a" !Oprint.out_module_type tmty
264
265
265
-
let space ppf () = Format.fprintf ppf "@ "
266
+
let space ppf () = Fmt.fprintf ppf "@ "
266
267
267
268
(**
268
269
In order to display a list of functor arguments in a compact format,
···
311
312
312
313
let make side pos =
313
314
match side with
314
-
| Got -> Format.sprintf "$S%d" pos
315
-
| Expected -> Format.sprintf "$T%d" pos
315
+
| Got -> Fmt.asprintf "$S%d" pos
316
+
| Expected -> Fmt.asprintf "$T%d" pos
316
317
| Unneeded -> "..."
317
318
318
319
(** Add shorthands to a patch *)
···
357
358
(** Printing of arguments with shorthands *)
358
359
let pp ppx = function
359
360
| Original x -> ppx x
360
-
| Synthetic s -> Format.dprintf "%s" s.name
361
+
| Synthetic s -> Fmt.dprintf "%s" s.name
361
362
362
363
let pp_orig ppx = function
363
364
| Original x | Synthetic { item=x; _ } -> ppx x
364
365
365
366
let definition x = match functor_param x with
366
-
| Unit -> Format.dprintf "()"
367
+
| Unit -> Fmt.dprintf "()"
367
368
| Named(_,short_mty) ->
368
369
match short_mty with
369
370
| Original mty -> dmodtype mty
370
371
| Synthetic {name; item = mty} ->
371
-
Format.dprintf
372
+
Fmt.dprintf
372
373
"%s@ =@ %t" name (dmodtype mty)
373
374
374
375
let param x = match functor_param x with
375
-
| Unit -> Format.dprintf "()"
376
+
| Unit -> Fmt.dprintf "()"
376
377
| Named (_, short_mty) ->
377
378
pp dmodtype short_mty
378
379
379
380
let qualified_param x = match functor_param x with
380
-
| Unit -> Format.dprintf "()"
381
+
| Unit -> Fmt.dprintf "()"
381
382
| Named (None, Original (Mty_signature []) ) ->
382
-
Format.dprintf "(sig end)"
383
+
Fmt.dprintf "(sig end)"
383
384
| Named (None, short_mty) ->
384
385
pp dmodtype short_mty
385
386
| Named (Some p, short_mty) ->
386
-
Format.dprintf "(%s : %t)"
387
+
Fmt.dprintf "(%s : %t)"
387
388
(Ident.name p) (pp dmodtype short_mty)
388
389
389
390
let definition_of_argument ua =
390
391
let arg, mty = ua.item in
391
392
match (arg: Err.functor_arg_descr) with
392
-
| Unit -> Format.dprintf "()"
393
-
| Empty_struct -> Format.dprintf "(struct end)"
393
+
| Unit -> Fmt.dprintf "()"
394
+
| Empty_struct -> Fmt.dprintf "(struct end)"
394
395
| Named p ->
395
396
let mty = modtype { ua with item = mty } in
396
-
Format.dprintf
397
+
Fmt.dprintf
397
398
"%a@ :@ %t"
398
399
Printtyp.path p
399
400
(pp_orig dmodtype mty)
···
402
403
begin match short_mty with
403
404
| Original mty -> dmodtype mty
404
405
| Synthetic {name; item=mty} ->
405
-
Format.dprintf "%s@ :@ %t" name (dmodtype mty)
406
+
Fmt.dprintf "%s@ :@ %t" name (dmodtype mty)
406
407
end
407
408
408
409
let arg ua =
409
410
let arg, mty = ua.item in
410
411
match (arg: Err.functor_arg_descr) with
411
-
| Unit -> Format.dprintf "()"
412
-
| Empty_struct -> Format.dprintf "(struct end)"
412
+
| Unit -> Fmt.dprintf "()"
413
+
| Empty_struct -> Fmt.dprintf "(struct end)"
413
414
| Named p -> fun ppf -> Printtyp.path ppf p
414
415
| Anonymous ->
415
416
let short_mty = modtype { ua with item=mty } in
···
429
430
let pretty_params sep proj printer patch =
430
431
let elt (x,param) =
431
432
let sty = Diffing.(style @@ classify x) in
432
-
Format.dprintf "%a%t%a"
433
-
Format.pp_open_stag (Style.Style sty)
433
+
Fmt.dprintf "%a%t%a"
434
+
Fmt.pp_open_stag (Style.Style sty)
434
435
(printer param)
435
-
Format.pp_close_stag ()
436
+
Fmt.pp_close_stag ()
436
437
in
437
438
let params = List.filter_map proj @@ List.map snd patch in
438
439
Printtyp.functor_parameters ~sep elt params
···
471
472
pretty_params space extract With_shorthand.qualified_param d
472
473
473
474
let insert mty =
474
-
Format.dprintf
475
+
Fmt.dprintf
475
476
"An argument appears to be missing with module type@;<1 2>@[%t@]"
476
477
(With_shorthand.definition mty)
477
478
478
479
let delete mty =
479
-
Format.dprintf
480
+
Fmt.dprintf
480
481
"An extra argument is provided of module type@;<1 2>@[%t@]"
481
482
(With_shorthand.definition mty)
482
483
483
484
let ok x y =
484
-
Format.dprintf
485
+
Fmt.dprintf
485
486
"Module types %t and %t match"
486
487
(With_shorthand.param x)
487
488
(With_shorthand.param y)
···
489
490
let diff g e more =
490
491
let g = With_shorthand.definition g in
491
492
let e = With_shorthand.definition e in
492
-
Format.dprintf
493
+
Fmt.dprintf
493
494
"Module types do not match:@ @[%t@]@;<1 -2>does not include@ \
494
495
@[%t@]%t"
495
496
g e (more ())
496
497
497
498
let incompatible = function
498
499
| Types.Unit ->
499
-
Format.dprintf
500
+
Fmt.dprintf
500
501
"The functor was expected to be applicative at this position"
501
502
| Types.Named _ ->
502
-
Format.dprintf
503
+
Fmt.dprintf
503
504
"The functor was expected to be generative at this position"
504
505
505
506
let patch env got expected =
···
525
526
pretty_params space extract With_shorthand.arg d
526
527
527
528
let delete mty =
528
-
Format.dprintf
529
+
Fmt.dprintf
529
530
"The following extra argument is provided@;<1 2>@[%t@]"
530
531
(With_shorthand.definition_of_argument mty)
531
532
···
534
535
let ok x y =
535
536
let pp_orig_name = match With_shorthand.functor_param y with
536
537
| With_shorthand.Named (_, Original mty) ->
537
-
Format.dprintf " %t" (dmodtype mty)
538
+
Fmt.dprintf " %t" (dmodtype mty)
538
539
| _ -> ignore
539
540
in
540
-
Format.dprintf
541
+
Fmt.dprintf
541
542
"Module %t matches the expected module type%t"
542
543
(With_shorthand.arg x)
543
544
pp_orig_name
···
545
546
let diff g e more =
546
547
let g = With_shorthand.definition_of_argument g in
547
548
let e = With_shorthand.definition e in
548
-
Format.dprintf
549
+
Fmt.dprintf
549
550
"Modules do not match:@ @[%t@]@;<1 -2>\
550
551
is not included in@ @[%t@]%t"
551
552
g e (more ())
···
556
557
let single_diff g e more =
557
558
let _arg, mty = g.With_shorthand.item in
558
559
let e = match e.With_shorthand.item with
559
-
| Types.Unit -> Format.dprintf "()"
560
+
| Types.Unit -> Fmt.dprintf "()"
560
561
| Types.Named(_, mty) -> dmodtype mty
561
562
in
562
-
Format.dprintf
563
+
Fmt.dprintf
563
564
"Modules do not match:@ @[%t@]@;<1 -2>\
564
565
is not included in@ @[%t@]%t"
565
566
(dmodtype mty) e (more ())
···
567
568
568
569
let incompatible = function
569
570
| Unit ->
570
-
Format.dprintf
571
+
Fmt.dprintf
571
572
"The functor was expected to be applicative at this position"
572
573
| Named _ | Anonymous ->
573
-
Format.dprintf
574
+
Fmt.dprintf
574
575
"The functor was expected to be generative at this position"
575
576
| Empty_struct ->
576
577
(* an empty structure can be used in both applicative and generative
···
580
581
581
582
let subcase sub ~expansion_token env (pos, diff) =
582
583
Location.msg "%a%a%a%a@[<hv 2>%t@]%a"
583
-
Format.pp_print_tab ()
584
-
Format.pp_open_tbox ()
584
+
Fmt.pp_print_tab ()
585
+
Fmt.pp_open_tbox ()
585
586
Diffing.prefix (pos, Diffing.classify diff)
586
-
Format.pp_set_tab ()
587
+
Fmt.pp_set_tab ()
587
588
(Printtyp.wrap_printing_env env ~error:true
588
589
(fun () -> sub ~expansion_token env diff)
589
590
)
590
-
Format.pp_close_tbox ()
591
+
Fmt.pp_close_tbox ()
591
592
592
593
let onlycase sub ~expansion_token env (_, diff) =
593
594
Location.msg "%a@[<hv 2>%t@]"
594
-
Format.pp_print_tab ()
595
+
Fmt.pp_print_tab ()
595
596
(Printtyp.wrap_printing_env env ~error:true
596
597
(fun () -> sub ~expansion_token env diff)
597
598
)
···
638
639
| [] -> ignore
639
640
| before ->
640
641
let ctx ppf =
641
-
Format.pp_print_list ~pp_sep:space
642
-
(fun ppf x -> x.Location.txt ppf)
642
+
Fmt.pp_print_list ~pp_sep:space
643
+
(fun ppf x -> Fmt.pp_doc ppf x.Location.txt)
643
644
ppf before in
644
645
ctx
645
646
646
647
let subcase_list l ppf = match l with
647
648
| [] -> ()
648
649
| _ :: _ ->
649
-
Format.fprintf ppf "@;<1 -2>@[%a@]"
650
-
(Format.pp_print_list ~pp_sep:space
651
-
(fun ppf f -> f.Location.txt ppf)
652
-
)
650
+
let pp_msg ppf lmsg = Fmt.pp_doc ppf lmsg.Location.txt in
651
+
Fmt.fprintf ppf "@;<1 -2>@[%a@]"
652
+
(Fmt.pp_print_list ~pp_sep:space pp_msg)
653
653
(List.rev l)
654
654
655
655
(* Printers for leaves *)
656
656
let core env id x =
657
657
match x with
658
658
| Err.Value_descriptions diff ->
659
-
Format.dprintf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
659
+
Fmt.dprintf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
660
660
"Values do not match"
661
661
!Oprint.out_sig_item
662
662
(Printtyp.tree_of_value_description id diff.got)
···
667
667
"the first" "the second" env) diff.symptom
668
668
show_locs (diff.got.val_loc, diff.expected.val_loc)
669
669
| Err.Type_declarations diff ->
670
-
Format.dprintf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
670
+
Fmt.dprintf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
671
671
"Type declarations do not match"
672
672
!Oprint.out_sig_item
673
673
(Printtyp.tree_of_type_declaration id diff.got Trec_first)
···
678
678
"the first" "the second" "declaration" env) diff.symptom
679
679
show_locs (diff.got.type_loc, diff.expected.type_loc)
680
680
| Err.Extension_constructors diff ->
681
-
Format.dprintf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a@]"
681
+
Fmt.dprintf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a@]"
682
682
"Extension declarations do not match"
683
683
!Oprint.out_sig_item
684
684
(Printtyp.tree_of_extension_constructor id diff.got Text_first)
···
689
689
"the first" "the second" "declaration" env) diff.symptom
690
690
show_locs (diff.got.ext_loc, diff.expected.ext_loc)
691
691
| Err.Class_type_declarations diff ->
692
-
Format.dprintf
692
+
Fmt.dprintf
693
693
"@[<hv 2>Class type declarations do not match:@ \
694
694
%a@;<1 -2>does not match@ %a@]@ %a"
695
695
!Oprint.out_sig_item
···
700
700
| Err.Class_declarations {got;expected;symptom} ->
701
701
let t1 = Printtyp.tree_of_class_declaration id got Trec_first in
702
702
let t2 = Printtyp.tree_of_class_declaration id expected Trec_first in
703
-
Format.dprintf
703
+
Fmt.dprintf
704
704
"@[<hv 2>Class declarations do not match:@ \
705
705
%a@;<1 -2>does not match@ %a@]@ %a"
706
706
!Oprint.out_sig_item t1
···
709
709
710
710
let missing_field ppf item =
711
711
let id, loc, kind = Includemod.item_ident_name item in
712
-
Format.fprintf ppf "The %s %a is required but not provided%a"
712
+
Fmt.fprintf ppf "The %s %a is required but not provided%a"
713
713
(Includemod.kind_of_field_desc kind)
714
714
(Style.as_inline_code Printtyp.ident) id
715
715
(show_loc "Expected declaration") loc
716
716
717
717
let module_types {Err.got=mty1; expected=mty2} =
718
-
Format.dprintf
718
+
Fmt.dprintf
719
719
"@[<hv 2>Modules do not match:@ \
720
720
%a@;<1 -2>is not included in@ %a@]"
721
721
!Oprint.out_module_type (Printtyp.tree_of_modtype mty1)
722
722
!Oprint.out_module_type (Printtyp.tree_of_modtype mty2)
723
723
724
724
let eq_module_types {Err.got=mty1; expected=mty2} =
725
-
Format.dprintf
725
+
Fmt.dprintf
726
726
"@[<hv 2>Module types do not match:@ \
727
727
%a@;<1 -2>is not equal to@ %a@]"
728
728
!Oprint.out_module_type (Printtyp.tree_of_modtype mty1)
729
729
!Oprint.out_module_type (Printtyp.tree_of_modtype mty2)
730
730
731
731
let module_type_declarations id {Err.got=d1 ; expected=d2} =
732
-
Format.dprintf
732
+
Fmt.dprintf
733
733
"@[<hv 2>Module type declarations do not match:@ \
734
734
%a@;<1 -2>does not match@ %a@]"
735
735
!Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1)
736
736
!Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2)
737
737
738
738
let interface_mismatch ppf (diff: _ Err.diff) =
739
-
Format.fprintf ppf
739
+
Fmt.fprintf ppf
740
740
"The implementation %a@ does not match the interface %a:@ "
741
741
Style.inline_code diff.got Style.inline_code diff.expected
742
742
···
745
745
| Not_an_alias | Not_an_identifier | Abstract_module_type
746
746
| Incompatible_aliases -> None
747
747
| Unbound_module_path path ->
748
-
Some(Format.dprintf "Unbound module %a"
748
+
Some(Fmt.dprintf "Unbound module %a"
749
749
(Style.as_inline_code Printtyp.path) path
750
750
)
751
751
···
787
787
module_type ~eqmode ~expansion_token ~env ~before ~ctx diff
788
788
| Invalid_module_alias path ->
789
789
let printer =
790
-
Format.dprintf "Module %a cannot be aliased"
790
+
Fmt.dprintf "Module %a cannot be aliased"
791
791
(Style.as_inline_code Printtyp.path) path
792
792
in
793
793
dwith_context ctx printer :: before
···
797
797
let actual = Functor_suberror.Inclusion.got d in
798
798
let expected = Functor_suberror.expected d in
799
799
let main =
800
-
Format.dprintf
800
+
Fmt.dprintf
801
801
"@[<hv 2>Modules do not match:@ \
802
802
@[functor@ %t@ -> ...@]@;<1 -2>is not included in@ \
803
803
@[functor@ %t@ -> ...@]@]"
···
823
823
if expansion_token then
824
824
let init_missings, last_missing = Misc.split_last missings in
825
825
List.map (Location.msg "%a" missing_field) init_missings
826
-
@ [ with_context ctx missing_field last_missing ]
827
-
@ before
826
+
@ with_context ctx missing_field last_missing
827
+
:: before
828
828
else
829
829
before
830
830
| [], a :: _ -> sigitem ~expansion_token ~env:sgs.env ~before ~ctx a
···
936
936
937
937
(* General error reporting *)
938
938
939
-
let err_msgs (env, err) =
939
+
let err_msgs ppf (env, err) =
940
940
Printtyp.wrap_printing_env ~error:true env
941
-
(fun () -> coalesce @@ all env err)
941
+
(fun () -> (coalesce @@ all env err) ppf)
942
942
943
943
let report_error err =
944
-
let main = err_msgs err in
945
944
Location.errorf
946
945
~loc:Location.(in_file !input_name)
947
946
~footnote:Printtyp.Conflicts.err_msg
948
-
"%t" main
947
+
"%a" err_msgs err
949
948
950
949
let report_apply_error ~loc env (app_name, mty_f, args) =
951
950
let footnote = Printtyp.Conflicts.err_msg in
···
986
985
let intro ppf =
987
986
match app_name with
988
987
| Includemod.Anonymous_functor ->
989
-
Format.fprintf ppf "This functor application is ill-typed."
988
+
Fmt.fprintf ppf "This functor application is ill-typed."
990
989
| Includemod.Full_application_path lid ->
991
-
Format.fprintf ppf "The functor application %a is ill-typed."
990
+
Fmt.fprintf ppf "The functor application %a is ill-typed."
992
991
(Style.as_inline_code Printtyp.longident) lid
993
992
| Includemod.Named_leftmost_functor lid ->
994
-
Format.fprintf ppf
993
+
Fmt.fprintf ppf
995
994
"This application of the functor %a is ill-typed."
996
995
(Style.as_inline_code Printtyp.longident) lid
997
996
in
···
1008
1007
intro
1009
1008
actual expected
1010
1009
1011
-
let coercion_in_package_subtype env mty c ppf =
1012
-
Runtime_coercion.in_package_subtype Context.alt_pp env mty c ppf
1010
+
let coercion_in_package_subtype env mty c =
1011
+
Format_doc.doc_printf "%t" @@
1012
+
Runtime_coercion.in_package_subtype Context.alt_pp env mty c
1013
1013
1014
1014
let register () =
1015
1015
Location.register_error_of_exn
+2
-3
typing/includemod_errorprinter.mli
+2
-3
typing/includemod_errorprinter.mli
···
13
13
(* *)
14
14
(**************************************************************************)
15
15
16
-
val err_msgs: Includemod.explanation -> Format.formatter -> unit
16
+
val err_msgs: Includemod.explanation Format_doc.printer
17
17
val coercion_in_package_subtype:
18
-
Env.t -> Types.module_type -> Typedtree.module_coercion -> Format.formatter ->
19
-
unit
18
+
Env.t -> Types.module_type -> Typedtree.module_coercion -> Format_doc.doc
20
19
val register: unit -> unit
+12
-7
typing/oprint.ml
+12
-7
typing/oprint.ml
···
13
13
(* *)
14
14
(**************************************************************************)
15
15
16
-
open Format
16
+
open Format_doc
17
17
open Outcometree
18
18
19
19
exception Ellipsis
···
249
249
in
250
250
cautious print_tree_1 ppf tree
251
251
252
-
let out_value = ref print_out_value
252
+
let out_value = ref (compat print_out_value)
253
253
254
254
(* Types *)
255
255
···
267
267
let pr_present =
268
268
print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
269
269
270
-
let pr_var = Pprintast.tyvar
270
+
let pr_var = Pprintast.Doc.tyvar
271
271
let ty_var ~non_gen ppf s =
272
272
pr_var ppf (if non_gen then "_" ^ s else s)
273
273
···
813
813
814
814
(* Phrases *)
815
815
816
+
open Format
817
+
816
818
let print_out_exception ppf exn outv =
817
819
match exn with
818
820
Sys.Break -> fprintf ppf "Interrupted.@."
···
847
849
otyext_constructors = exts;
848
850
otyext_private = ext.oext_private }
849
851
in
850
-
fprintf ppf "@[%a@]" !out_type_extension te;
852
+
fprintf ppf "@[%a@]" (Format_doc.compat !out_type_extension) te;
851
853
if items <> [] then fprintf ppf "@ %a" print_items items
852
854
| (tree, valopt) :: items ->
853
855
begin match valopt with
854
856
Some v ->
855
-
fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree
857
+
fprintf ppf "@[<2>%a =@ %a@]" (Format_doc.compat !out_sig_item) tree
856
858
!out_value v
857
-
| None -> fprintf ppf "@[%a@]" !out_sig_item tree
859
+
| None -> fprintf ppf "@[%a@]" (Format_doc.compat !out_sig_item) tree
858
860
end;
859
861
if items <> [] then fprintf ppf "@ %a" print_items items
860
862
861
863
let print_out_phrase ppf =
862
864
function
863
865
Ophr_eval (outv, ty) ->
864
-
fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv
866
+
fprintf ppf "@[- : %a@ =@ %a@]@." (compat !out_type) ty !out_value outv
865
867
| Ophr_signature [] -> ()
866
868
| Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
867
869
| Ophr_exception (exn, outv) -> print_out_exception ppf exn outv
868
870
869
871
let out_phrase = ref print_out_phrase
872
+
873
+
type 'a printer = 'a Format_doc.printer ref
874
+
type 'a toplevel_printer = (Format.formatter -> 'a -> unit) ref
+16
-16
typing/oprint.mli
+16
-16
typing/oprint.mli
···
13
13
(* *)
14
14
(**************************************************************************)
15
15
16
-
open Format
17
16
open Outcometree
18
17
19
-
val out_ident : (formatter -> out_ident -> unit) ref
20
-
val out_value : (formatter -> out_value -> unit) ref
21
-
val out_label : (formatter -> string * bool * out_type -> unit) ref
22
-
val out_type : (formatter -> out_type -> unit) ref
23
-
val out_type_args : (formatter -> out_type list -> unit) ref
24
-
val out_constr : (formatter -> out_constructor -> unit) ref
25
-
val out_class_type : (formatter -> out_class_type -> unit) ref
26
-
val out_module_type : (formatter -> out_module_type -> unit) ref
27
-
val out_sig_item : (formatter -> out_sig_item -> unit) ref
28
-
val out_signature : (formatter -> out_sig_item list -> unit) ref
18
+
type 'a printer = 'a Format_doc.printer ref
19
+
type 'a toplevel_printer = (Format.formatter -> 'a -> unit) ref
20
+
21
+
val out_ident: out_ident printer
22
+
val out_value : out_value toplevel_printer
23
+
val out_label : (string * bool * out_type ) printer
24
+
val out_type : out_type printer
25
+
val out_type_args : out_type list printer
26
+
val out_constr : out_constructor printer
27
+
val out_class_type : out_class_type printer
28
+
val out_module_type : out_module_type printer
29
+
val out_sig_item : out_sig_item printer
30
+
val out_signature :out_sig_item list printer
29
31
val out_functor_parameters :
30
-
(formatter ->
31
-
(string option * Outcometree.out_module_type) option list -> unit)
32
-
ref
33
-
val out_type_extension : (formatter -> out_type_extension -> unit) ref
34
-
val out_phrase : (formatter -> out_phrase -> unit) ref
32
+
(string option * Outcometree.out_module_type) option list printer
33
+
val out_type_extension : out_type_extension printer
34
+
val out_phrase : out_phrase toplevel_printer
35
35
36
36
val parenthesized_ident : string -> bool
+1
-1
typing/outcometree.mli
+1
-1
typing/outcometree.mli
···
49
49
| Oval_int64 of int64
50
50
| Oval_nativeint of nativeint
51
51
| Oval_list of out_value list
52
-
| Oval_printer of (Format.formatter -> unit)
52
+
| Oval_printer of (Format_doc.formatter -> unit)
53
53
| Oval_record of (out_ident * out_value) list
54
54
| Oval_string of string * int * out_string (* string, size-to-print, kind *)
55
55
| Oval_stuff of string
+7
-7
typing/parmatch.ml
+7
-7
typing/parmatch.ml
···
1884
1884
| Seq.Cons (v, _rest) ->
1885
1885
if Warnings.is_active (Warnings.Partial_match "") then begin
1886
1886
let errmsg =
1887
-
let buf = Buffer.create 16 in
1888
-
let fmt = Format.formatter_of_buffer buf in
1889
-
Format.fprintf fmt "@[<v>%a" Printpat.pretty_pat v;
1887
+
let doc = ref Format_doc.empty in
1888
+
let fmt = Format_doc.formatter doc in
1889
+
Format_doc.fprintf fmt "@[<v>%a" Printpat.top_pretty v;
1890
1890
if do_match (initial_only_guarded casel) [v] then
1891
-
Format.fprintf fmt
1891
+
Format_doc.fprintf fmt
1892
1892
"@,(However, some guarded clause may match this value.)";
1893
1893
if contains_extension v then
1894
-
Format.fprintf fmt
1894
+
Format_doc.fprintf fmt
1895
1895
"@,@[Matching over values of extensible variant types \
1896
1896
(the *extension* above)@,\
1897
1897
must include a wild card pattern@ in order to be exhaustive.@]"
1898
1898
;
1899
-
Format.fprintf fmt "@]@?";
1900
-
Buffer.contents buf
1899
+
Format_doc.fprintf fmt "@]";
1900
+
Format_doc.(asprintf "%a" pp_doc) !doc
1901
1901
in
1902
1902
Location.prerr_warning loc (Warnings.Partial_match errmsg)
1903
1903
end;
+2
-2
typing/path.ml
+2
-2
typing/path.ml
···
104
104
let rec print ppf = function
105
105
| Pident id -> Ident.print_with_scope ppf id
106
106
| Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) ->
107
-
Format.fprintf ppf "%a.%s" print p s
108
-
| Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2
107
+
Format_doc.fprintf ppf "%a.%s" print p s
108
+
| Papply(p1, p2) -> Format_doc.fprintf ppf "%a(%a)" print p1 print p2
109
109
| Pextra_ty (p, Pext_ty) -> print ppf p
110
110
111
111
let rec head = function
+1
-1
typing/path.mli
+1
-1
typing/path.mli
+6
-4
typing/persistent_env.ml
+6
-4
typing/persistent_env.ml
···
243
243
let warn = Warnings.No_cmi_file(name, None) in
244
244
Location.prerr_warning loc warn
245
245
| Cmi_format.Error err ->
246
-
let msg = Format.asprintf "%a" Cmi_format.report_error err in
246
+
let msg = Format.asprintf "%a"
247
+
(Format_doc.compat Cmi_format.report_error) err in
247
248
let warn = Warnings.No_cmi_file(name, Some msg) in
248
249
Location.prerr_warning loc warn
249
250
| Error err ->
250
251
let msg =
251
252
match err with
252
253
| Illegal_renaming(name, ps_name, filename) ->
253
-
Format.asprintf
254
+
Format_doc.doc_printf
254
255
" %a@ contains the compiled interface for @ \
255
256
%a when %a was expected"
256
257
(Style.as_inline_code Location.print_filename) filename
···
258
259
Style.inline_code name
259
260
| Inconsistent_import _ -> assert false
260
261
| Need_recursive_types name ->
261
-
Format.asprintf
262
+
Format_doc.doc_printf
262
263
"%a uses recursive types"
263
264
Style.inline_code name
264
265
in
266
+
let msg = Format_doc.(asprintf "%a" pp_doc) msg in
265
267
let warn = Warnings.No_cmi_file(name, Some msg) in
266
268
Location.prerr_warning loc warn
267
269
···
350
352
~exceptionally:(fun () -> remove_file filename)
351
353
352
354
let report_error ppf =
353
-
let open Format in
355
+
let open Format_doc in
354
356
function
355
357
| Illegal_renaming(modname, ps_name, filename) -> fprintf ppf
356
358
"Wrong file naming: %a@ contains the compiled interface for@ \
+1
-1
typing/persistent_env.mli
+1
-1
typing/persistent_env.mli
+3
-3
typing/primitive.ml
+3
-3
typing/primitive.ml
···
232
232
let report_error ppf err =
233
233
match err with
234
234
| Old_style_float_with_native_repr_attribute ->
235
-
Format.fprintf ppf "Cannot use %a in conjunction with %a/%a."
235
+
Format_doc.fprintf ppf "Cannot use %a in conjunction with %a/%a."
236
236
Style.inline_code "float"
237
237
Style.inline_code "[@unboxed]"
238
238
Style.inline_code "[@untagged]"
239
239
| Old_style_noalloc_with_noalloc_attribute ->
240
-
Format.fprintf ppf "Cannot use %a in conjunction with %a."
240
+
Format_doc.fprintf ppf "Cannot use %a in conjunction with %a."
241
241
Style.inline_code "noalloc"
242
242
Style.inline_code "[@@noalloc]"
243
243
| No_native_primitive_with_repr_attribute ->
244
-
Format.fprintf ppf
244
+
Format_doc.fprintf ppf
245
245
"@[The native code version of the primitive is mandatory@ \
246
246
when attributes %a or %a are present.@]"
247
247
Style.inline_code "[@untagged]"
+20
-10
typing/printpat.ml
+20
-10
typing/printpat.ml
···
18
18
open Asttypes
19
19
open Typedtree
20
20
open Types
21
-
open Format
21
+
open Format_doc
22
22
23
23
let is_cons = function
24
24
| {cstr_name = "::"} -> true
···
99
99
| Tpat_lazy v ->
100
100
fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
101
101
| Tpat_alias (v, x,_,_) ->
102
-
fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
102
+
fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.doc_print x
103
103
| Tpat_value v ->
104
104
fprintf ppf "%a" pretty_val (v :> pattern)
105
105
| Tpat_exception v ->
···
144
144
fprintf ppf "%s=%a;@ %a"
145
145
lbl.lbl_name pretty_val v pretty_lvals rest
146
146
147
+
let top_pretty ppf v =
148
+
fprintf ppf "@[%a@]" pretty_val v
149
+
147
150
let pretty_pat ppf p =
148
-
fprintf ppf "@[%a@]" pretty_val p
151
+
top_pretty ppf p ;
152
+
pp_print_flush ppf ()
149
153
150
154
type 'k matrix = 'k general_pattern list list
151
155
152
156
let pretty_line ppf line =
153
-
Format.fprintf ppf "@[";
157
+
fprintf ppf "@[";
154
158
List.iter (fun p ->
155
-
Format.fprintf ppf "<%a>@ "
156
-
pretty_val p
157
-
) line;
158
-
Format.fprintf ppf "@]"
159
+
fprintf ppf "<%a>@ "
160
+
pretty_val p
161
+
) line;
162
+
fprintf ppf "@]"
159
163
160
164
let pretty_matrix ppf (pss : 'k matrix) =
161
-
Format.fprintf ppf "@[<v 2> %a@]"
162
-
(Format.pp_print_list ~pp_sep:Format.pp_print_cut pretty_line)
165
+
fprintf ppf "@[<v 2> %a@]"
166
+
(pp_print_list ~pp_sep:pp_print_cut pretty_line)
163
167
pss
168
+
169
+
module Compat = struct
170
+
let pretty_pat ppf x = compat pretty_pat ppf x
171
+
let pretty_line ppf x = compat pretty_line ppf x
172
+
let pretty_matrix ppf x = compat pretty_matrix ppf x
173
+
end
+8
-7
typing/printpat.mli
+8
-7
typing/printpat.mli
···
17
17
18
18
val pretty_const
19
19
: Asttypes.constant -> string
20
-
val pretty_val : Format.formatter -> 'k Typedtree.general_pattern -> unit
21
20
22
-
val pretty_pat
23
-
: Format.formatter -> 'k Typedtree.general_pattern -> unit
24
-
val pretty_line
25
-
: Format.formatter -> 'k Typedtree.general_pattern list -> unit
26
-
val pretty_matrix
27
-
: Format.formatter -> 'k Typedtree.general_pattern list list -> unit
21
+
val top_pretty: 'k Typedtree.general_pattern Format_doc.printer
22
+
23
+
module Compat: sig
24
+
val pretty_pat: Format.formatter -> 'k Typedtree.general_pattern -> unit
25
+
val pretty_line: Format.formatter -> 'k Typedtree.general_pattern list -> unit
26
+
val pretty_matrix:
27
+
Format.formatter -> 'k Typedtree.general_pattern list list -> unit
28
+
end
+83
-70
typing/printtyp.ml
+83
-70
typing/printtyp.ml
···
17
17
18
18
open Misc
19
19
open Ctype
20
-
open Format
21
20
open Longident
22
21
open Path
23
22
open Asttypes
···
30
29
module Style = Misc.Style
31
30
32
31
(* Print a long identifier *)
33
-
let longident = Pprintast.longident
32
+
33
+
module Fmt = Format_doc
34
+
open Format_doc
35
+
36
+
let longident = Pprintast.Doc.longident
34
37
35
38
let () = Env.print_longident := longident
36
39
···
79
82
80
83
81
84
let pp ppf x =
82
-
Format.pp_print_string ppf (Shape.Sig_component_kind.to_string x)
85
+
Fmt.pp_print_string ppf (Shape.Sig_component_kind.to_string x)
83
86
84
87
(** The two functions below should never access the filesystem,
85
88
and thus use {!in_printing_env} rather than directly
···
157
160
end
158
161
159
162
let pp_explanation ppf r=
160
-
Format.fprintf ppf "@[<v 2>%a:@,Definition of %s %a@]"
163
+
Fmt.fprintf ppf "@[<v 2>%a:@,Definition of %s %a@]"
161
164
Location.print_loc r.location (Sig_component_kind.to_string r.kind)
162
165
Style.inline_code r.name
163
166
164
167
let print_located_explanations ppf l =
165
-
Format.fprintf ppf "@[<v>%a@]" (Format.pp_print_list pp_explanation) l
168
+
Fmt.fprintf ppf "@[<v>%a@]"
169
+
(Fmt.pp_print_list pp_explanation) l
166
170
167
171
let reset () = explanations := M.empty
168
172
let list_explanations () =
···
172
176
173
177
174
178
let print_toplevel_hint ppf l =
175
-
let conj ppf () = Format.fprintf ppf " and@ " in
176
-
let pp_namespace_plural ppf n = Format.fprintf ppf "%as" Namespace.pp n in
179
+
let conj ppf () = Fmt.fprintf ppf " and@ " in
180
+
let pp_namespace_plural ppf n = Fmt.fprintf ppf "%as" Namespace.pp n in
177
181
let root_names = List.map (fun r -> r.kind, r.root_name) l in
178
182
let unique_root_names = List.sort_uniq Stdlib.compare root_names in
179
183
let submsgs = Array.make Namespace.size [] in
···
184
188
match names with
185
189
| [] -> ()
186
190
| [namespace, a] ->
187
-
Format.fprintf ppf
191
+
Fmt.fprintf ppf
188
192
"@,\
189
193
@[<2>@{<hint>Hint@}: The %a %a has been defined multiple times@ \
190
194
in@ this@ toplevel@ session.@ \
···
193
197
Namespace.pp namespace
194
198
Style.inline_code a Namespace.pp namespace
195
199
| (namespace, _) :: _ :: _ ->
196
-
Format.fprintf ppf
200
+
Fmt.fprintf ppf
197
201
"@,\
198
202
@[<2>@{<hint>Hint@}: The %a %a have been defined multiple times@ \
199
203
in@ this@ toplevel@ session.@ \
200
204
Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\
201
205
@ Did you try to redefine them?@]"
202
206
pp_namespace_plural namespace
203
-
Format.(pp_print_list ~pp_sep:conj Style.inline_code)
207
+
Fmt.(pp_print_list ~pp_sep:conj Style.inline_code)
204
208
(List.map snd names)
205
209
pp_namespace_plural namespace in
206
210
Array.iter (pp_submsg ppf) submsgs
···
216
220
| [], [] -> None
217
221
| _ ->
218
222
Some
219
-
(Format.dprintf "%a%a"
223
+
(Fmt.doc_printf "%a%a"
220
224
print_located_explanations l
221
225
print_toplevel_hint ltop
222
226
)
223
-
let err_print ppf = Option.iter (Format.fprintf ppf "@,%t") (err_msg ())
227
+
let err_print ppf = Option.iter Fmt.(fprintf ppf "@,%a" pp_doc) (err_msg ())
224
228
225
229
let exists () = M.cardinal !explanations >0
226
230
end
···
438
442
!Oprint.out_ident ppf (tree_of_path ~disambiguation:false None p)
439
443
440
444
let string_of_path p =
441
-
Format.asprintf "%a" path p
445
+
Format.asprintf "%a" (Fmt.compat path) p
442
446
443
447
let strings_of_paths namespace p =
444
448
let trees = List.map (tree_of_path namespace) p in
445
-
List.map (Format.asprintf "%a" !Oprint.out_ident) trees
449
+
List.map (Fmt.asprintf "%a" !Oprint.out_ident) trees
446
450
447
451
let () = Env.print_path := path
448
452
···
452
456
| Trec_not -> Orec_not
453
457
| Trec_first -> Orec_first
454
458
| Trec_next -> Orec_next
455
-
456
459
457
460
(* Normalize paths *)
458
461
···
587
590
if error then Env.without_cmis (wrap_printing_env env) f
588
591
else wrap_printing_env env f
589
592
590
-
let wrap_printing_env_error env f =
591
-
let wrap_txt f fmt = wrap_printing_env ~error:true env (fun () -> f fmt) in
592
-
let wrap (loc : _ Location.loc) = { loc with txt = wrap_txt loc.txt } in
593
-
let err : Location.error = wrap_printing_env ~error:true env f in
594
-
{ Location.kind = err.kind;
595
-
main = wrap err.main;
596
-
sub = List.map wrap err.sub;
597
-
footnote = (fun () -> wrap_printing_env ~error:true env (fun () ->
598
-
Option.map wrap_txt (err.footnote ())));
599
-
}
600
-
601
593
let rec lid_of_path = function
602
594
Path.Pident id ->
603
595
Longident.Lident (Ident.name id)
···
720
712
| _ ->
721
713
Btype.iter_type_expr f ty
722
714
715
+
let quoted_ident ppf x =
716
+
Style.as_inline_code !Oprint.out_ident ppf x
717
+
723
718
module Internal_names : sig
724
719
725
720
val reset : unit -> unit
726
721
727
722
val add : Path.t -> unit
728
723
729
-
val print_explanations : Env.t -> Format.formatter -> unit
724
+
val print_explanations : Env.t -> Fmt.formatter -> unit
730
725
731
726
end = struct
732
727
···
768
763
fprintf ppf
769
764
"@ @[<2>@{<hint>Hint@}:@ %a@ is an existential type@ \
770
765
bound by the constructor@ %a.@]"
771
-
(Style.as_inline_code !Oprint.out_ident) out_ident
766
+
quoted_ident out_ident
772
767
Style.inline_code constr
773
768
| out_ident :: out_idents ->
774
769
fprintf ppf
775
770
"@ @[<2>@{<hint>Hint@}:@ %a@ and %a@ are existential types@ \
776
771
bound by the constructor@ %a.@]"
777
-
(Format.pp_print_list
772
+
(Fmt.pp_print_list
778
773
~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
779
-
(Style.as_inline_code !Oprint.out_ident))
774
+
quoted_ident)
780
775
(List.rev out_idents)
781
-
(Style.as_inline_code !Oprint.out_ident) out_ident
776
+
quoted_ident out_ident
782
777
Style.inline_code constr)
783
778
constrs
784
779
···
1587
1582
ext.ext_args
1588
1583
ext.ext_ret_type
1589
1584
in
1590
-
Format.fprintf ppf "@[<hv>%a@]"
1585
+
Fmt.fprintf ppf "@[<hv>%a@]"
1591
1586
!Oprint.out_constr {
1592
1587
ocstr_name = name;
1593
1588
ocstr_args = args;
···
1960
1955
let rec functor_parameters ~sep custom_printer = function
1961
1956
| [] -> ignore
1962
1957
| [id,param] ->
1963
-
Format.dprintf "%t%t"
1958
+
Fmt.dprintf "%t%t"
1964
1959
(custom_printer param)
1965
1960
(functor_param ~sep ~custom_printer id [])
1966
1961
| (id,param) :: q ->
1967
-
Format.dprintf "%t%a%t"
1962
+
Fmt.dprintf "%t%a%t"
1968
1963
(custom_printer param)
1969
1964
sep ()
1970
1965
(functor_param ~sep ~custom_printer id q)
···
2007
2002
begin match Conflicts.err_msg () with
2008
2003
| None -> ()
2009
2004
| Some msg ->
2010
-
let conflicts = Format.asprintf "%t" msg in
2005
+
let conflicts = asprintf "%a" pp_doc msg in
2011
2006
Location.prerr_warning (Location.in_file sourcefile)
2012
2007
(Warnings.Erroneous_printed_signature conflicts);
2013
2008
Warnings.check_fatal ()
2014
2009
end;
2015
-
fprintf ppf "%a" print_signature t
2010
+
compat print_signature ppf t
2016
2011
2017
2012
(* Trace-specific printing *)
2018
2013
···
2068
2063
else Diff(first,second)
2069
2064
end
2070
2065
2066
+
let pp_type ppf t =
2067
+
Style.as_inline_code !Oprint.out_type ppf t
2068
+
2069
+
let quoted_ident ppf t =
2070
+
Style.as_inline_code !Oprint.out_ident ppf t
2071
+
2071
2072
let type_expansion ppf = function
2072
-
| Same t -> Style.as_inline_code !Oprint.out_type ppf t
2073
+
| Same t -> pp_type ppf t
2073
2074
| Diff(t,t') ->
2074
2075
fprintf ppf "@[<2>%a@ =@ %a@]"
2075
-
(Style.as_inline_code !Oprint.out_type) t
2076
-
(Style.as_inline_code !Oprint.out_type) t'
2076
+
pp_type t
2077
+
pp_type t'
2077
2078
2078
2079
let trees_of_trace mode =
2079
2080
List.map (Errortrace.map_diff (trees_of_type_expansion mode))
···
2083
2084
Diff(tree_of_path (Some Type) tp, tree_of_path (Some Type) tp')
2084
2085
2085
2086
let type_path_expansion ppf = function
2086
-
| Same p -> Style.as_inline_code !Oprint.out_ident ppf p
2087
+
| Same p -> quoted_ident ppf p
2087
2088
| Diff(p,p') ->
2088
2089
fprintf ppf "@[<2>%a@ =@ %a@]"
2089
-
(Style.as_inline_code !Oprint.out_ident) p
2090
-
(Style.as_inline_code !Oprint.out_ident) p'
2090
+
quoted_ident p
2091
+
quoted_ident p'
2091
2092
2092
2093
let rec trace fst txt ppf = function
2093
2094
| {Errortrace.got; expected} :: rem ->
···
2149
2150
| Errortrace.Diff d :: rem -> d :: filter_trace keep_last rem
2150
2151
| _ :: rem -> filter_trace keep_last rem
2151
2152
2152
-
let type_path_list =
2153
-
Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0)
2154
-
type_path_expansion
2153
+
let type_path_list ppf l =
2154
+
Fmt.pp_print_list ~pp_sep:(fun ppf () -> Fmt.pp_print_break ppf 2 0)
2155
+
type_path_expansion ppf l
2155
2156
2156
2157
(* Hide variant name and var, to force printing the expanded type *)
2157
2158
let hide_variant_name t =
···
2178
2179
| _ -> prepare_expansion ty_exp
2179
2180
2180
2181
let print_path p =
2181
-
Format.dprintf "%a" !Oprint.out_ident (tree_of_path (Some Type) p)
2182
+
Fmt.dprintf "%a" !Oprint.out_ident (tree_of_path (Some Type) p)
2182
2183
2183
2184
let print_tag ppf s = Style.inline_code ppf ("`" ^ s)
2184
2185
2185
-
let print_tags =
2186
-
let comma ppf () = Format.fprintf ppf ",@ " in
2187
-
Format.pp_print_list ~pp_sep:comma print_tag
2186
+
let print_tags ppf tags =
2187
+
Fmt.(pp_print_list ~pp_sep:comma) print_tag ppf tags
2188
2188
2189
2189
let is_unit env ty =
2190
2190
match get_desc (Ctype.expand_head env ty) with
···
2200
2200
Btype.backtrack snap;
2201
2201
res
2202
2202
2203
-
let explanation_diff env t3 t4 : (Format.formatter -> unit) option =
2203
+
2204
+
let explanation_diff env t3 t4 =
2204
2205
match get_desc t3, get_desc t4 with
2205
2206
| Tarrow (_, ty1, ty2, _), _
2206
2207
when is_unit env ty1 && unifiable env ty2 t4 ->
···
2212
2213
| _, Tarrow (_, ty1, ty2, _)
2213
2214
when is_unit env ty1 && unifiable env t3 ty2 ->
2214
2215
Some (fun ppf ->
2215
-
fprintf ppf
2216
+
fprintf ppf
2216
2217
"@,@[@{<hint>Hint@}: Did you forget to wrap the expression using \
2217
2218
%a?@]"
2218
2219
Style.inline_code "fun () ->"
···
2343
2344
Style.(as_inline_code path) p
2344
2345
)
2345
2346
| Errortrace.Package_inclusion pr ->
2346
-
Some(dprintf "@,@[%t@]" pr)
2347
+
Some(dprintf "@,@[%a@]" Fmt.pp_doc pr)
2347
2348
| Errortrace.Package_coercion pr ->
2348
-
Some(dprintf "@,@[%t@]" pr)
2349
+
Some(dprintf "@,@[%a@]" Fmt.pp_doc pr)
2349
2350
2350
2351
let explanation (type variety) intro prev env
2351
2352
: (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function
···
2356
2357
match context, kind, prev with
2357
2358
| Some ctx, _, _ ->
2358
2359
reserve_names ctx;
2359
-
dprintf "@[%t@;<1 2>%a@]" intro
2360
+
dprintf "@[%a@;<1 2>%a@]" pp_doc intro
2360
2361
(Style.as_inline_code type_expr_with_reserved_names) ctx
2361
2362
| None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) ->
2362
2363
explain_incompatible_fields name diff
···
2397
2398
let mismatch intro env trace =
2398
2399
Errortrace.explain trace (fun ~prev h -> explanation intro prev env h)
2399
2400
2400
-
let explain mis ppf =
2401
+
let explain mis ppf =
2401
2402
match mis with
2402
2403
| None -> ()
2403
2404
| Some explain -> explain ppf
···
2431
2432
| None -> ignore
2432
2433
| Some d ->
2433
2434
let d = Errortrace.map_diff (trees_of_type_expansion mode) d in
2434
-
dprintf "%t@;<1 2>%a@ %t@;<1 2>%a"
2435
-
txt_got type_expansion d.Errortrace.got
2436
-
txt_but type_expansion d.Errortrace.expected
2435
+
dprintf "%a@;<1 2>%a@ %a@;<1 2>%a"
2436
+
pp_doc txt_got type_expansion d.Errortrace.got
2437
+
pp_doc txt_but type_expansion d.Errortrace.expected
2437
2438
2438
2439
let warn_on_missing_defs env ppf = function
2439
2440
| None -> ()
···
2466
2467
let tr = trees_of_trace mode tr in
2467
2468
fprintf ppf
2468
2469
"@[<v>\
2469
-
@[%t%t@]%a%t\
2470
+
@[%t%a@]%a%t\
2470
2471
@]"
2471
2472
head_error
2472
-
ty_expect_explanation
2473
+
pp_doc ty_expect_explanation
2473
2474
(trace false (incompatibility_phrase trace_format)) tr
2474
2475
(explain mis);
2475
2476
if env <> Env.empty
···
2483
2484
2484
2485
let report_error trace_format ppf mode env tr
2485
2486
?(subst = [])
2486
-
?(type_expected_explanation = fun _ -> ())
2487
+
?(type_expected_explanation = Fmt.empty)
2487
2488
txt1 txt2 =
2488
2489
wrap_printing_env ~error:true env (fun () ->
2489
2490
error trace_format mode subst env tr txt1 ppf txt2
···
2577
2578
(trace filter_subtype_trace subtype_get_diff true keep_first txt1)
2578
2579
tr_sub;
2579
2580
if tr_unif = [] then fprintf ppf "@]" else
2580
-
let mis = mismatch (dprintf "Within this type") env tr_unif in
2581
+
let mis = mismatch (doc_printf "Within this type") env tr_unif in
2581
2582
fprintf ppf "%a%t%t@]"
2582
2583
(trace filter_trace unification_get_diff false
2583
2584
(mis = None) "is not compatible with type") tr_unif
···
2594
2595
[] -> assert false
2595
2596
| [tp] ->
2596
2597
fprintf ppf
2597
-
"@[%t@;<1 2>%a@ \
2598
-
%t@;<1 2>%a\
2598
+
"@[%a@;<1 2>%a@ \
2599
+
%a@;<1 2>%a\
2599
2600
@]"
2600
-
txt1 type_path_expansion (trees_of_type_path_expansion tp)
2601
-
txt3 type_path_expansion tp0
2601
+
pp_doc txt1 type_path_expansion (trees_of_type_path_expansion tp)
2602
+
pp_doc txt3 type_path_expansion tp0
2602
2603
| _ ->
2603
2604
fprintf ppf
2604
-
"@[%t@;<1 2>@[<hv>%a@]\
2605
-
@ %t@;<1 2>%a\
2605
+
"@[%a@;<1 2>@[<hv>%a@]\
2606
+
@ %a@;<1 2>%a\
2606
2607
@]"
2607
-
txt2 type_path_list (List.map trees_of_type_path_expansion tpl)
2608
-
txt3 type_path_expansion tp0)
2608
+
pp_doc txt2 type_path_list (List.map trees_of_type_path_expansion tpl)
2609
+
pp_doc txt3 type_path_expansion tp0)
2609
2610
2610
2611
(* Adapt functions to exposed interface *)
2611
2612
let tree_of_path = tree_of_path None
···
2615
2616
let tree_of_type_declaration ident td rs =
2616
2617
with_hidden_items [{hide=true; ident}]
2617
2618
(fun () -> tree_of_type_declaration ident td rs)
2619
+
2620
+
(** Compatibility module for Format printers *)
2621
+
module Compat = struct
2622
+
let longident = Fmt.compat longident
2623
+
let path = Fmt.compat path
2624
+
let type_expr = Fmt.compat type_expr
2625
+
let shared_type_scheme = Fmt.compat shared_type_scheme
2626
+
let signature = Fmt.compat signature
2627
+
let class_type = Fmt.compat class_type
2628
+
let modtype = Fmt.compat modtype
2629
+
let string_of_label = string_of_label
2630
+
end
+51
-48
typing/printtyp.mli
+51
-48
typing/printtyp.mli
···
15
15
16
16
(* Printing functions *)
17
17
18
-
open Format
18
+
open Format_doc
19
19
open Types
20
20
open Outcometree
21
21
22
-
val longident: formatter -> Longident.t -> unit
23
-
val ident: formatter -> Ident.t -> unit
22
+
val longident: Longident.t printer
23
+
val ident: Ident.t printer
24
24
val namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string
25
25
val tree_of_path: Path.t -> out_ident
26
-
val path: formatter -> Path.t -> unit
26
+
val path: Path.t printer
27
27
val string_of_path: Path.t -> string
28
28
29
-
val type_path: formatter -> Path.t -> unit
29
+
val type_path: Path.t printer
30
30
(** Print a type path taking account of [-short-paths].
31
31
Calls should be within [wrap_printing_env]. *)
32
32
···
46
46
(* This affects all the printing functions below *)
47
47
(* Also, if [~error:true], then disable the loading of cmis *)
48
48
49
-
(** [wrap_printing_env_error env f] ensures that all printing functions in a
50
-
[Location.error] report are evaluated within the [wrap_printing_env
51
-
~error:true env] context. (The original call to [f] is also evaluated
52
-
within that context.)
53
-
*)
54
-
val wrap_printing_env_error :
55
-
Env.t -> (unit -> Location.error) -> Location.error
56
-
57
49
module Naming_context: sig
58
50
val enable: bool -> unit
59
51
(** When contextual names are enabled, the mapping between identifiers
···
80
72
collected up to this point, and reset the list of collected
81
73
explanations *)
82
74
83
-
val print_located_explanations:
84
-
Format.formatter -> explanation list -> unit
75
+
val print_located_explanations: explanation list printer
85
76
86
-
val err_msg: unit -> (Format.formatter -> unit) option
77
+
val err_msg: unit -> doc option
87
78
(** [err_msg ()] return an error message if there are pending conflict
88
79
explanations at this point. It is often important to check for conflicts
89
80
after all printing is done, thus the delayed nature of [err_msg]*)
···
99
90
other type formatters such as [prepared_type_expr].) If you want multiple
100
91
types to use common names for type variables, see [prepare_for_printing] and
101
92
[prepared_type_expr]. *)
102
-
val type_expr: formatter -> type_expr -> unit
93
+
val type_expr: type_expr printer
103
94
104
95
(** [prepare_for_printing] resets the global printing environment, a la [reset],
105
96
and prepares the types for printing by reserving names and marking loops.
···
112
103
*)
113
104
val add_type_to_preparation: type_expr -> unit
114
105
115
-
val prepared_type_expr: formatter -> type_expr -> unit
106
+
val prepared_type_expr: type_expr printer
116
107
(** The function [prepared_type_expr] is a less-safe but more-flexible version
117
108
of [type_expr] that should only be called on [type_expr]s that have been
118
109
passed to [prepare_for_printing]. Unlike [type_expr], this function does no
···
123
114
[prepared_type_expr], they will use the same names for the same type
124
115
variables. *)
125
116
126
-
val constructor_arguments: formatter -> constructor_arguments -> unit
117
+
val constructor_arguments: constructor_arguments printer
127
118
val tree_of_type_scheme: type_expr -> out_type
128
-
val type_scheme: formatter -> type_expr -> unit
129
-
val prepared_type_scheme: formatter -> type_expr -> unit
130
-
val shared_type_scheme: formatter -> type_expr -> unit
119
+
val type_scheme: type_expr printer
120
+
val prepared_type_scheme: type_expr printer
121
+
val shared_type_scheme: type_expr printer
131
122
(** [shared_type_scheme] is very similar to [type_scheme], but does not reset
132
123
the printing context first. This is intended to be used in cases where the
133
124
printing should have a particularly wide context, such as documentation
···
135
126
for which [type_scheme] is better suited. *)
136
127
137
128
val tree_of_value_description: Ident.t -> value_description -> out_sig_item
138
-
val value_description: Ident.t -> formatter -> value_description -> unit
139
-
val label : formatter -> label_declaration -> unit
129
+
val value_description: Ident.t -> value_description printer
130
+
val label : label_declaration printer
140
131
val add_constructor_to_preparation : constructor_declaration -> unit
141
-
val prepared_constructor : formatter -> constructor_declaration -> unit
142
-
val constructor : formatter -> constructor_declaration -> unit
132
+
val prepared_constructor : constructor_declaration printer
133
+
val constructor : constructor_declaration printer
143
134
val tree_of_type_declaration:
144
135
Ident.t -> type_declaration -> rec_status -> out_sig_item
145
136
val add_type_declaration_to_preparation :
146
137
Ident.t -> type_declaration -> unit
147
-
val prepared_type_declaration: Ident.t -> formatter -> type_declaration -> unit
148
-
val type_declaration: Ident.t -> formatter -> type_declaration -> unit
138
+
val prepared_type_declaration: Ident.t -> type_declaration printer
139
+
val type_declaration: Ident.t -> type_declaration printer
149
140
val tree_of_extension_constructor:
150
141
Ident.t -> extension_constructor -> ext_status -> out_sig_item
151
142
val add_extension_constructor_to_preparation :
152
143
extension_constructor -> unit
153
144
val prepared_extension_constructor:
154
-
Ident.t -> formatter -> extension_constructor -> unit
145
+
Ident.t -> extension_constructor printer
155
146
val extension_constructor:
156
-
Ident.t -> formatter -> extension_constructor -> unit
147
+
Ident.t -> extension_constructor printer
157
148
(* Prints extension constructor with the type signature:
158
149
type ('a, 'b) bar += A of float
159
150
*)
160
151
161
152
val extension_only_constructor:
162
-
Ident.t -> formatter -> extension_constructor -> unit
153
+
Ident.t -> extension_constructor printer
163
154
(* Prints only extension constructor without type signature:
164
155
A of float
165
156
*)
166
157
167
158
val tree_of_module:
168
159
Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item
169
-
val modtype: formatter -> module_type -> unit
170
-
val signature: formatter -> signature -> unit
160
+
val modtype: module_type printer
161
+
val signature: signature printer
171
162
val tree_of_modtype: module_type -> out_module_type
172
163
val tree_of_modtype_declaration:
173
164
Ident.t -> modtype_declaration -> out_sig_item
···
183
174
expect: (_: sig end) (Y:X.T) (_:sig end) (Z:X.T)
184
175
*)
185
176
val functor_parameters:
186
-
sep:(Format.formatter -> unit -> unit) ->
187
-
('b -> Format.formatter -> unit) ->
188
-
(Ident.t option * 'b) list -> Format.formatter -> unit
177
+
sep:unit printer -> ('b -> Format_doc.formatter -> unit) ->
178
+
(Ident.t option * 'b) list -> Format_doc.formatter -> unit
189
179
190
180
type type_or_scheme = Type | Type_scheme
191
181
192
182
val tree_of_signature: Types.signature -> out_sig_item list
193
183
val tree_of_typexp: type_or_scheme -> type_expr -> out_type
194
-
val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit
195
-
val class_type: formatter -> class_type -> unit
184
+
val modtype_declaration: Ident.t -> modtype_declaration printer
185
+
val class_type: class_type printer
196
186
val tree_of_class_declaration:
197
187
Ident.t -> class_declaration -> rec_status -> out_sig_item
198
-
val class_declaration: Ident.t -> formatter -> class_declaration -> unit
188
+
val class_declaration: Ident.t -> class_declaration printer
199
189
val tree_of_cltype_declaration:
200
190
Ident.t -> class_type_declaration -> rec_status -> out_sig_item
201
-
val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit
191
+
val cltype_declaration: Ident.t -> class_type_declaration printer
202
192
val type_expansion :
203
-
type_or_scheme -> Format.formatter -> Errortrace.expanded_type -> unit
193
+
type_or_scheme -> Errortrace.expanded_type printer
204
194
val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type
195
+
196
+
module Compat: sig
197
+
(** {!Format} compatible printers *)
198
+
type 'a printer := Format.formatter -> 'a -> unit
199
+
val longident : Longident.t printer
200
+
val path: Path.t printer
201
+
val type_expr: type_expr printer
202
+
val shared_type_scheme: type_expr printer
203
+
val signature: signature printer
204
+
val modtype: module_type printer
205
+
val class_type: class_type printer
206
+
val string_of_label: Asttypes.arg_label -> string
207
+
end
208
+
205
209
val report_ambiguous_type_error:
206
210
formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list ->
207
-
(formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit
211
+
Format_doc.t -> Format_doc.t -> Format_doc.t -> unit
208
212
209
213
val report_unification_error :
210
214
formatter ->
211
215
Env.t -> Errortrace.unification_error ->
212
-
?type_expected_explanation:(formatter -> unit) ->
213
-
(formatter -> unit) -> (formatter -> unit) ->
216
+
?type_expected_explanation:Format_doc.t -> Format_doc.t -> Format_doc.t ->
214
217
unit
215
218
216
219
val report_equality_error :
217
220
formatter ->
218
221
type_or_scheme ->
219
222
Env.t -> Errortrace.equality_error ->
220
-
(formatter -> unit) -> (formatter -> unit) ->
223
+
Format_doc.t -> Format_doc.t ->
221
224
unit
222
225
223
226
val report_moregen_error :
224
227
formatter ->
225
228
type_or_scheme ->
226
229
Env.t -> Errortrace.moregen_error ->
227
-
(formatter -> unit) -> (formatter -> unit) ->
230
+
Format_doc.t -> Format_doc.t ->
228
231
unit
229
232
230
233
val report_comparison_error :
231
234
formatter ->
232
235
type_or_scheme ->
233
236
Env.t -> Errortrace.comparison_error ->
234
-
(formatter -> unit) -> (formatter -> unit) ->
237
+
Format_doc.t -> Format_doc.t ->
235
238
unit
236
239
237
240
module Subtype : sig
···
253
256
254
257
(** [printed_signature sourcefile ppf sg] print the signature [sg] of
255
258
[sourcefile] with potential warnings for name collisions *)
256
-
val printed_signature: string -> formatter -> signature -> unit
259
+
val printed_signature: string -> Format.formatter -> signature -> unit
+2
-2
typing/rawprinttyp.ml
+2
-2
typing/rawprinttyp.ml
···
51
51
None -> fprintf ppf "None"
52
52
| Some name -> fprintf ppf "\"%s\"" name
53
53
54
-
let path = Path.print
54
+
let path = Format_doc.compat Path.print
55
55
56
56
let visited = ref []
57
57
let rec raw_type ppf ty =
···
77
77
| Ttuple tl ->
78
78
fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
79
79
| Tconstr (p, tl, abbrev) ->
80
-
fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" Path.print p
80
+
fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
81
81
raw_type_list tl
82
82
(raw_list path) (list_of_memo !abbrev)
83
83
| Tobject (t, nm) ->
+4
-1
typing/stypes.ml
+4
-1
typing/stypes.ml
···
148
148
printtyp_reset_maybe loc;
149
149
Format.pp_print_string Format.str_formatter " ";
150
150
Printtyp.wrap_printing_env ~error:false env
151
-
(fun () -> Printtyp.shared_type_scheme Format.str_formatter typ);
151
+
(fun () ->
152
+
Format_doc.compat Printtyp.shared_type_scheme Format.str_formatter
153
+
typ
154
+
);
152
155
Format.pp_print_newline Format.str_formatter ();
153
156
let s = Format.flush_str_formatter () in
154
157
output_string pp s;
+33
-38
typing/typeclass.ml
+33
-38
typing/typeclass.ml
···
19
19
open Types
20
20
open Typecore
21
21
open Typetexp
22
-
open Format
23
22
24
23
25
24
type 'a class_info = {
···
48
47
49
48
type 'a full_class = {
50
49
id : Ident.t;
51
-
id_loc : tag loc;
50
+
id_loc : string loc;
52
51
clty: class_declaration;
53
52
ty_id: Ident.t;
54
53
cltydef: class_type_declaration;
···
94
93
| Bad_class_type_parameters of Ident.t * type_expr list * type_expr list
95
94
| Class_match_failure of Ctype.class_match_failure list
96
95
| Unbound_val of string
97
-
| Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
96
+
| Unbound_type_var of Format_doc.t * Ctype.closed_class_failure
98
97
| Non_generalizable_class of
99
98
{ id : Ident.t
100
99
; clty : Types.class_declaration
···
1743
1742
| Some reason ->
1744
1743
let printer =
1745
1744
if define_class
1746
-
then function ppf -> Printtyp.class_declaration id ppf clty
1747
-
else function ppf -> Printtyp.cltype_declaration id ppf cltydef
1745
+
then Format_doc.doc_printf "%a" (Printtyp.class_declaration id) clty
1746
+
else Format_doc.doc_printf "%a" (Printtyp.cltype_declaration id) cltydef
1748
1747
in
1749
1748
raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason)))
1750
1749
end;
···
1980
1979
1981
1980
(* Error report *)
1982
1981
1983
-
open Format
1982
+
open Format_doc
1984
1983
1985
1984
let non_virtual_string_of_kind : kind -> string = function
1986
1985
| Object -> "object"
···
1988
1987
| Class_type -> "non-virtual class type"
1989
1988
1990
1989
module Style=Misc.Style
1990
+
1991
+
let out_type ppf t = Style.as_inline_code !Oprint.out_type ppf t
1991
1992
1992
1993
let report_error env ppf =
1993
1994
let pp_args ppf args =
···
1998
1999
| Repeated_parameter ->
1999
2000
fprintf ppf "A type parameter occurs several times"
2000
2001
| Unconsistent_constraint err ->
2002
+
let msg = Format_doc.Core.msg in
2001
2003
fprintf ppf "@[<v>The class constraints are not consistent.@ ";
2002
2004
Printtyp.report_unification_error ppf env err
2003
-
(fun ppf -> fprintf ppf "Type")
2004
-
(fun ppf -> fprintf ppf "is not compatible with type");
2005
+
(msg "Type")
2006
+
(msg "is not compatible with type");
2005
2007
fprintf ppf "@]"
2006
2008
| Field_type_mismatch (k, m, err) ->
2009
+
let msg = Format_doc.doc_printf in
2007
2010
Printtyp.report_unification_error ppf env err
2008
-
(function ppf ->
2009
-
fprintf ppf "The %s %a@ has type" k Style.inline_code m)
2010
-
(function ppf ->
2011
-
fprintf ppf "but is expected to have type")
2011
+
(msg "The %s %a@ has type" k Style.inline_code m)
2012
+
(msg "but is expected to have type")
2012
2013
| Unexpected_field (ty, lab) ->
2013
2014
fprintf ppf
2014
2015
"@[@[<2>This object is expected to have type :@ %a@]\
···
2046
2047
Printtyp.prepare_for_printing [abbrev; actual; expected];
2047
2048
fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
2048
2049
but is used with type@ %a@]"
2049
-
(Style.as_inline_code !Oprint.out_type)
2050
-
(Printtyp.tree_of_typexp Type abbrev)
2051
-
(Style.as_inline_code !Oprint.out_type)
2052
-
(Printtyp.tree_of_typexp Type actual)
2053
-
(Style.as_inline_code !Oprint.out_type)
2054
-
(Printtyp.tree_of_typexp Type expected)
2050
+
out_type (Printtyp.tree_of_typexp Type abbrev)
2051
+
out_type (Printtyp.tree_of_typexp Type actual)
2052
+
out_type (Printtyp.tree_of_typexp Type expected)
2055
2053
| Constructor_type_mismatch (c, err) ->
2054
+
let msg = Format_doc.doc_printf in
2056
2055
Printtyp.report_unification_error ppf env err
2057
-
(function ppf ->
2058
-
fprintf ppf "The expression %a has type"
2056
+
(msg "The expression %a has type"
2059
2057
Style.inline_code ("new " ^ c)
2060
2058
)
2061
-
(function ppf ->
2062
-
fprintf ppf "but is used with type")
2059
+
(msg "but is used with type")
2063
2060
| Virtual_class (kind, mets, vals) ->
2064
2061
let kind = non_virtual_string_of_kind kind in
2065
2062
let missings =
···
2085
2082
but is here applied to %i type argument(s)@]"
2086
2083
(Style.as_inline_code Printtyp.longident) lid expected provided
2087
2084
| Parameter_mismatch err ->
2085
+
let msg = Format_doc.Core.msg in
2088
2086
Printtyp.report_unification_error ppf env err
2089
-
(function ppf ->
2090
-
fprintf ppf "The type parameter")
2091
-
(function ppf ->
2092
-
fprintf ppf "does not meet its constraint: it should be")
2087
+
(msg "The type parameter")
2088
+
(msg "does not meet its constraint: it should be")
2093
2089
| Bad_parameters (id, params, cstrs) ->
2094
2090
Printtyp.prepare_for_printing (params @ cstrs);
2095
2091
fprintf ppf
···
2112
2108
Includeclass.report_error Type ppf error
2113
2109
| Unbound_val lab ->
2114
2110
fprintf ppf "Unbound instance variable %a" Style.inline_code lab
2115
-
| Unbound_type_var (printer, reason) ->
2111
+
| Unbound_type_var (msg, reason) ->
2116
2112
let print_reason ppf { Ctype.free_variable; meth; meth_ty; } =
2117
2113
let (ty0, kind) = free_variable in
2118
2114
let ty1 =
···
2122
2118
in
2123
2119
Printtyp.add_type_to_preparation meth_ty;
2124
2120
Printtyp.add_type_to_preparation ty1;
2125
-
let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in
2126
2121
fprintf ppf
2127
2122
"The method %a@ has type@;<1 2>%a@ where@ %a@ is unbound"
2128
2123
Style.inline_code meth
2129
-
pp_type (Printtyp.tree_of_typexp Type meth_ty)
2130
-
pp_type (Printtyp.tree_of_typexp Type ty0)
2124
+
out_type (Printtyp.tree_of_typexp Type meth_ty)
2125
+
out_type (Printtyp.tree_of_typexp Type ty0)
2131
2126
in
2132
2127
fprintf ppf
2133
-
"@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
2128
+
"@[<v>@[Some type variables are unbound in this type:@;<1 2>%a@]@ \
2134
2129
@[%a@]@]"
2135
-
printer print_reason reason
2130
+
pp_doc msg print_reason reason
2136
2131
| Non_generalizable_class {id; clty; nongen_vars } ->
2137
2132
let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2] in
2138
2133
Printtyp.prepare_for_printing nongen_vars;
···
2152
2147
Some occurrences are contravariant@]"
2153
2148
(Style.as_inline_code Printtyp.type_scheme) ty
2154
2149
| Non_collapsable_conjunction (id, clty, err) ->
2150
+
let msg = Format_doc.Core.msg in
2155
2151
fprintf ppf
2156
2152
"@[The type of this class,@ %a,@ \
2157
2153
contains non-collapsible conjunctive types in constraints.@ %t@]"
2158
2154
(Style.as_inline_code @@ Printtyp.class_declaration id) clty
2159
2155
(fun ppf -> Printtyp.report_unification_error ppf env err
2160
-
(fun ppf -> fprintf ppf "Type")
2161
-
(fun ppf -> fprintf ppf "is not compatible with type")
2156
+
(msg "Type")
2157
+
(msg "is not compatible with type")
2162
2158
)
2163
2159
| Self_clash err ->
2160
+
let msg = Format_doc.Core.msg in
2164
2161
Printtyp.report_unification_error ppf env err
2165
-
(function ppf ->
2166
-
fprintf ppf "This object is expected to have type")
2167
-
(function ppf ->
2168
-
fprintf ppf "but actually has type")
2162
+
(msg "This object is expected to have type")
2163
+
(msg "but actually has type")
2169
2164
| Mutability_mismatch (_lab, mut) ->
2170
2165
let mut1, mut2 =
2171
2166
if mut = Immutable then "mutable", "immutable"
+2
-4
typing/typeclass.mli
+2
-4
typing/typeclass.mli
···
15
15
16
16
open Asttypes
17
17
open Types
18
-
open Format
19
-
20
18
type 'a class_info = {
21
19
cls_id : Ident.t;
22
20
cls_id_loc : string loc;
···
111
109
| Bad_class_type_parameters of Ident.t * type_expr list * type_expr list
112
110
| Class_match_failure of Ctype.class_match_failure list
113
111
| Unbound_val of string
114
-
| Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
112
+
| Unbound_type_var of Format_doc.t * Ctype.closed_class_failure
115
113
| Non_generalizable_class of
116
114
{ id : Ident.t
117
115
; clty : Types.class_declaration
···
129
127
exception Error of Location.t * Env.t * error
130
128
exception Error_forward of Location.error
131
129
132
-
val report_error : Env.t -> formatter -> error -> unit
130
+
val report_error : Env.t -> error Format_doc.printer
133
131
134
132
(* Forward decl filled in by Typemod.type_open_descr *)
135
133
val type_open_descr :
+71
-82
typing/typecore.ml
+71
-82
typing/typecore.ml
···
201
201
| Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr
202
202
| Expr_not_a_record_type of type_expr
203
203
204
+
205
+
let not_principal fmt =
206
+
Format_doc.Core.kmsg (fun x -> Warnings.Not_principal x) fmt
207
+
204
208
exception Error of Location.t * Env.t * error
205
209
exception Error_forward of Location.error
206
210
···
947
951
generalize_structure t2;
948
952
if not (fully_generic t1 && fully_generic t2) then
949
953
let msg =
950
-
Format.asprintf
954
+
Format_doc.doc_printf
951
955
"typing this pattern requires considering@ %a@ and@ %a@ as \
952
956
equal.@,\
953
957
But the knowledge of these types"
···
1164
1168
let paths = ambiguous_types env lbl rest in
1165
1169
let expansion = match Printtyp.Conflicts.err_msg () with
1166
1170
| None -> ""
1167
-
| Some msg -> Format.asprintf "%t" msg
1171
+
| Some msg -> Format_doc.(asprintf "%a" pp_doc) msg
1168
1172
in
1169
1173
if paths <> [] then
1170
1174
warn lid.loc
···
1176
1180
let warn_non_principal warn lid =
1177
1181
let name = Datatype_kind.label_name kind in
1178
1182
warn lid.loc
1179
-
(Warnings.Not_principal
1180
-
("this type-based " ^ name ^ " disambiguation"))
1183
+
(not_principal "this type-based %s disambiguation" name)
1181
1184
1182
1185
(* we selected a name out of the lexical scope *)
1183
1186
let warn_out_of_scope warn lid env tpath =
1184
1187
if Warnings.is_active (Name_out_of_scope ("",[],false)) then begin
1185
1188
let path_s =
1186
1189
Printtyp.wrap_printing_env ~error:true env
1187
-
(fun () -> Format.asprintf "%a" Printtyp.type_path tpath) in
1190
+
(fun () -> Format_doc.asprintf "%a" Printtyp.type_path tpath) in
1188
1191
warn lid.loc
1189
1192
(Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false))
1190
1193
end
···
1424
1427
in
1425
1428
if !w_pr then
1426
1429
Location.prerr_warning loc
1427
-
(Warnings.Not_principal "this type-based record disambiguation")
1430
+
(not_principal "this type-based record disambiguation")
1428
1431
else begin
1429
1432
match List.rev !w_amb with
1430
1433
(_,types,ex)::_ as amb ->
···
3364
3367
| Tconstr(path, _, _) when Path.same path fmt6_path ->
3365
3368
if !Clflags.principal && get_level ty_exp <> generic_level then
3366
3369
Location.prerr_warning loc
3367
-
(Warnings.Not_principal "this coercion to format6");
3370
+
(not_principal "this coercion to format6");
3368
3371
true
3369
3372
| _ -> false
3370
3373
in
···
3996
3999
| Tpoly (ty, tl) ->
3997
4000
if !Clflags.principal && get_level typ <> generic_level then
3998
4001
Location.prerr_warning loc
3999
-
(Warnings.Not_principal "this use of a polymorphic method");
4002
+
(not_principal "this use of a polymorphic method");
4000
4003
snd (instance_poly ~fixed:false tl ty)
4001
4004
| Tvar _ ->
4002
4005
let ty' = newvar () in
···
4263
4266
< Btype.generic_level
4264
4267
then
4265
4268
Location.prerr_warning loc
4266
-
(Warnings.Not_principal "this module packing");
4269
+
(not_principal "this module packing");
4267
4270
(p, fl)
4268
4271
| Tvar _ ->
4269
4272
raise (Error (loc, env, Cannot_infer_signature))
···
4456
4459
force (); force' ();
4457
4460
if not gen && !Clflags.principal then
4458
4461
Location.prerr_warning loc
4459
-
(Warnings.Not_principal "this ground coercion");
4462
+
(not_principal "this ground coercion");
4460
4463
with Subtype err ->
4461
4464
(* prerr_endline "coercion failed"; *)
4462
4465
raise (Error (loc, env, Not_subtype err))
···
5426
5429
(fun () -> type_argument env sarg ty ty0)
5427
5430
else begin
5428
5431
may_warn sarg.pexp_loc
5429
-
(Warnings.Not_principal "using an optional argument here");
5432
+
(not_principal "using an optional argument here");
5430
5433
(fun () -> option_some env (type_argument env sarg
5431
5434
(extract_option_type env ty)
5432
5435
(extract_option_type env ty0)))
···
5465
5468
| Some (l', sarg, commuted, remaining_sargs) ->
5466
5469
if commuted then begin
5467
5470
may_warn sarg.pexp_loc
5468
-
(Warnings.Not_principal "commuting this argument")
5471
+
(not_principal "commuting this argument")
5469
5472
end;
5470
5473
if not optional && is_optional l' then
5471
5474
Location.prerr_warning sarg.pexp_loc
···
6466
6469
let spellcheck_idents ppf unbound valid_idents =
6467
6470
spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents)
6468
6471
6469
-
open Format
6472
+
open Format_doc
6473
+
module Fmt = Format_doc
6470
6474
6471
6475
let longident = Printtyp.longident
6472
6476
···
6496
6500
Some '.'
6497
6501
else None
6498
6502
in
6499
-
let pp_const ppf (c,s) = Format.fprintf ppf "%s%c" c s in
6503
+
let pp_const ppf (c,s) = Fmt.fprintf ppf "%s%c" c s in
6500
6504
match const_str, suffix with
6501
6505
| Some c, Some s -> [
6502
6506
Location.msg
···
6536
6540
| Some (Ppat_constant const) -> report_literal_type_constraint const diff
6537
6541
| _ -> []
6538
6542
6539
-
let report_type_expected_explanation expl ppf =
6540
-
let because expl_str = fprintf ppf "@ because it is in %s" expl_str in
6543
+
let report_type_expected_explanation expl =
6544
+
let because expl_str = doc_printf "@ because it is in %s" expl_str in
6541
6545
match expl with
6542
6546
| If_conditional ->
6543
6547
because "the condition of an if-statement"
···
6560
6564
| When_guard ->
6561
6565
because "a when-guard"
6562
6566
6563
-
let report_type_expected_explanation_opt expl ppf =
6567
+
let report_type_expected_explanation_opt expl =
6564
6568
match expl with
6565
-
| None -> ()
6566
-
| Some expl -> report_type_expected_explanation expl ppf
6569
+
| None -> Format_doc.empty
6570
+
| Some expl -> report_type_expected_explanation expl
6567
6571
6568
6572
let report_unification_error ~loc ?sub env err
6569
6573
?type_expected_explanation txt1 txt2 =
···
6573
6577
) ()
6574
6578
6575
6579
let report_this_function ppf funct =
6576
-
if Typedtree.exp_is_nominal funct then
6577
-
let pexp = Untypeast.untype_expression funct in
6578
-
Format.fprintf ppf "The function %a"
6579
-
(Style.as_inline_code Pprintast.expression) pexp
6580
-
else Format.fprintf ppf "This function"
6580
+
match Typedtree.nominal_exp_doc Printtyp.longident funct with
6581
+
| None -> Fmt.fprintf ppf "This function"
6582
+
| Some name ->
6583
+
Fmt.fprintf ppf "The function %a"
6584
+
(Style.as_inline_code Fmt.pp_doc) name
6581
6585
6582
6586
let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc
6583
6587
~extra_arg_loc ~returns_unit loc =
···
6609
6613
@ It is applied to too many arguments@]"
6610
6614
report_this_function funct Printtyp.type_expr func_ty
6611
6615
6616
+
let msg = Fmt.doc_printf
6617
+
6612
6618
let report_error ~loc env = function
6613
6619
| Constructor_arity_mismatch(lid, expected, provided) ->
6614
6620
Location.errorf ~loc
···
6617
6623
(Style.as_inline_code longident) lid expected provided
6618
6624
| Label_mismatch(lid, err) ->
6619
6625
report_unification_error ~loc env err
6620
-
(function ppf ->
6621
-
fprintf ppf "The record field %a@ belongs to the type"
6626
+
(msg "The record field %a@ belongs to the type"
6622
6627
(Style.as_inline_code longident) lid)
6623
-
(function ppf ->
6624
-
fprintf ppf "but is mixed here with fields of type")
6628
+
(msg "but is mixed here with fields of type")
6625
6629
| Pattern_type_clash (err, pat) ->
6626
6630
let diff = type_clash_of_trace err.trace in
6627
6631
let sub = report_pattern_type_clash_hints pat diff in
6628
6632
report_unification_error ~loc ~sub env err
6629
-
(function ppf ->
6630
-
fprintf ppf "This pattern matches values of type")
6631
-
(function ppf ->
6632
-
fprintf ppf "but a pattern was expected which matches values of \
6633
-
type");
6633
+
(msg "This pattern matches values of type")
6634
+
(msg "but a pattern was expected which matches values of type");
6634
6635
| Or_pattern_type_clash (id, err) ->
6635
6636
report_unification_error ~loc env err
6636
-
(function ppf ->
6637
-
fprintf ppf "The variable %a on the left-hand side of this \
6637
+
(msg "The variable %a on the left-hand side of this \
6638
6638
or-pattern has type" Style.inline_code (Ident.name id))
6639
-
(function ppf ->
6640
-
fprintf ppf "but on the right-hand side it has type")
6639
+
(msg "but on the right-hand side it has type")
6641
6640
| Multiply_bound_variable name ->
6642
6641
Location.errorf ~loc
6643
6642
"Variable %a is bound several times in this matching"
···
6657
6656
report_unification_error ~loc ~sub env err
6658
6657
~type_expected_explanation:
6659
6658
(report_type_expected_explanation_opt explanation)
6660
-
(function ppf ->
6661
-
fprintf ppf "This expression has type")
6662
-
(function ppf ->
6663
-
fprintf ppf "but an expression was expected of type");
6659
+
(msg "This expression has type")
6660
+
(msg "but an expression was expected of type");
6664
6661
| Function_arity_type_clash {
6665
6662
syntactic_arity; type_constraint; trace = { trace };
6666
6663
} ->
···
6759
6756
(Style.as_inline_code Printtyp.type_path) type_path;
6760
6757
end else begin
6761
6758
fprintf ppf
6762
-
"@[@[<2>%s type@ %a%t@]@ \
6759
+
"@[@[<2>%s type@ %a%a@]@ \
6763
6760
There is no %s %a within type %a@]"
6764
6761
eorp (Style.as_inline_code Printtyp.type_expr) ty
6765
-
(report_type_expected_explanation_opt explanation)
6762
+
pp_doc (report_type_expected_explanation_opt explanation)
6766
6763
(Datatype_kind.label_name kind)
6767
6764
Style.inline_code name.txt
6768
6765
(Style.as_inline_code Printtyp.type_path) type_path;
···
6774
6771
let name = Datatype_kind.label_name kind in
6775
6772
Location.error_of_printer ~loc (fun ppf () ->
6776
6773
Printtyp.report_ambiguous_type_error ppf env tp tpl
6777
-
(function ppf ->
6778
-
fprintf ppf "The %s %a@ belongs to the %s type"
6774
+
(msg "The %s %a@ belongs to the %s type"
6779
6775
name (Style.as_inline_code longident) lid
6780
6776
type_name)
6781
-
(function ppf ->
6782
-
fprintf ppf "The %s %a@ belongs to one of the following %s types:"
6777
+
(msg "The %s %a@ belongs to one of the following %s types:"
6783
6778
name (Style.as_inline_code longident) lid type_name)
6784
-
(function ppf ->
6785
-
fprintf ppf "but a %s was expected belonging to the %s type"
6779
+
(msg "but a %s was expected belonging to the %s type"
6786
6780
name type_name)
6787
-
) ()
6781
+
) ()
6788
6782
| Invalid_format msg ->
6789
6783
Location.errorf ~loc "%s" msg
6790
6784
| Not_an_object (ty, explanation) ->
···
6792
6786
fprintf ppf "This expression is not an object;@ \
6793
6787
it has type %a"
6794
6788
(Style.as_inline_code Printtyp.type_expr) ty;
6795
-
report_type_expected_explanation_opt explanation ppf
6789
+
pp_doc ppf @@ report_type_expected_explanation_opt explanation
6796
6790
) ()
6797
6791
| Undefined_method (ty, me, valid_methods) ->
6798
6792
Location.error_of_printer ~loc (fun ppf () ->
···
6836
6830
Style.inline_code v
6837
6831
| Coercion_failure (ty_exp, err, b) ->
6838
6832
Location.error_of_printer ~loc (fun ppf () ->
6833
+
let intro =
6834
+
let ty_exp = Printtyp.prepare_expansion ty_exp in
6835
+
doc_printf "This expression cannot be coerced to type@;<1 2>%a;@ \
6836
+
it has type"
6837
+
(Style.as_inline_code @@ Printtyp.type_expansion Type) ty_exp
6838
+
in
6839
6839
Printtyp.report_unification_error ppf env err
6840
-
(function ppf ->
6841
-
let ty_exp = Printtyp.prepare_expansion ty_exp in
6842
-
fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \
6843
-
it has type"
6844
-
(Style.as_inline_code @@ Printtyp.type_expansion Type) ty_exp)
6845
-
(function ppf ->
6846
-
fprintf ppf "but is here used with type");
6840
+
intro
6841
+
(Fmt.doc_printf "but is here used with type");
6847
6842
if b then
6848
6843
fprintf ppf
6849
6844
".@.@[<hov>This simple coercion was not fully general.@ \
···
6854
6849
| Not_a_function (ty, explanation) ->
6855
6850
Location.errorf ~loc
6856
6851
"This expression should not be a function,@ \
6857
-
the expected type is@ %a%t"
6852
+
the expected type is@ %a%a"
6858
6853
(Style.as_inline_code Printtyp.type_expr) ty
6859
-
(report_type_expected_explanation_opt explanation)
6854
+
pp_doc (report_type_expected_explanation_opt explanation)
6860
6855
| Too_many_arguments (ty, explanation) ->
6861
6856
Location.errorf ~loc
6862
6857
"This function expects too many arguments,@ \
6863
-
it should have type@ %a%t"
6858
+
it should have type@ %a%a"
6864
6859
(Style.as_inline_code Printtyp.type_expr) ty
6865
-
(report_type_expected_explanation_opt explanation)
6860
+
pp_doc (report_type_expected_explanation_opt explanation)
6866
6861
| Abstract_wrong_label {got; expected; expected_type; explanation} ->
6867
6862
let label ~long ppf = function
6868
6863
| Nolabel -> fprintf ppf "unlabeled"
···
6877
6872
| _ -> false
6878
6873
in
6879
6874
Location.errorf ~loc
6880
-
"@[<v>@[<2>This function should have type@ %a%t@]@,\
6875
+
"@[<v>@[<2>This function should have type@ %a%a@]@,\
6881
6876
@[but its first argument is %a@ instead of %s%a@]@]"
6882
6877
(Style.as_inline_code Printtyp.type_expr) expected_type
6883
-
(report_type_expected_explanation_opt explanation)
6878
+
pp_doc (report_type_expected_explanation_opt explanation)
6884
6879
(label ~long:true) got
6885
6880
(if second_long then "being " else "")
6886
6881
(label ~long:second_long) expected
···
6913
6908
This is only allowed when the real type is known."
6914
6909
| Less_general (kind, err) ->
6915
6910
report_unification_error ~loc env err
6916
-
(fun ppf -> fprintf ppf "This %s has type" kind)
6917
-
(fun ppf -> fprintf ppf "which is less general than")
6911
+
(Fmt.doc_printf "This %s has type" kind)
6912
+
(Fmt.doc_printf "which is less general than")
6918
6913
| Modules_not_allowed ->
6919
6914
Location.errorf ~loc "Modules are not allowed in this pattern."
6920
6915
| Cannot_infer_signature ->
···
6984
6979
"@[%s@ %s@ @[%a@]@]"
6985
6980
"This match case could not be refuted."
6986
6981
"Here is an example of a value that would reach it:"
6987
-
(Style.as_inline_code Printpat.pretty_val) pat
6982
+
(Style.as_inline_code Printpat.top_pretty) pat
6988
6983
| Invalid_extension_constructor_payload ->
6989
6984
Location.errorf ~loc
6990
6985
"Invalid %a payload, a constructor is expected."
···
7014
7009
"This kind of recursive class expression is not allowed"
7015
7010
| Letop_type_clash(name, err) ->
7016
7011
report_unification_error ~loc env err
7017
-
(function ppf ->
7018
-
fprintf ppf "The operator %a has type" Style.inline_code name)
7019
-
(function ppf ->
7020
-
fprintf ppf "but it was expected to have type")
7012
+
(msg "The operator %a has type" Style.inline_code name)
7013
+
(msg "but it was expected to have type")
7021
7014
| Andop_type_clash(name, err) ->
7022
7015
report_unification_error ~loc env err
7023
-
(function ppf ->
7024
-
fprintf ppf "The operator %a has type" Style.inline_code name)
7025
-
(function ppf ->
7026
-
fprintf ppf "but it was expected to have type")
7016
+
(msg "The operator %a has type" Style.inline_code name)
7017
+
(msg "but it was expected to have type")
7027
7018
| Bindings_type_clash(err) ->
7028
7019
report_unification_error ~loc env err
7029
-
(function ppf ->
7030
-
fprintf ppf "These bindings have type")
7031
-
(function ppf ->
7032
-
fprintf ppf "but bindings were expected of type")
7020
+
(Fmt.doc_printf "These bindings have type")
7021
+
(Fmt.doc_printf "but bindings were expected of type")
7033
7022
| Unbound_existential (ids, ty) ->
7034
7023
let pp_ident ppf id = pp_print_string ppf (Ident.name id) in
7035
7024
let pp_type ppf (ids,ty)=
···
7076
7065
in
7077
7066
Location.errorf ~loc
7078
7067
"This %s should not be a %s,@ \
7079
-
the expected type is@ %a%t"
7068
+
the expected type is@ %a%a"
7080
7069
ctx sort (Style.as_inline_code Printtyp.type_expr) ty
7081
-
(report_type_expected_explanation_opt explanation)
7070
+
pp_doc (report_type_expected_explanation_opt explanation)
7082
7071
| Expr_not_a_record_type ty ->
7083
7072
Location.errorf ~loc
7084
7073
"This expression has type %a@ \
···
7086
7075
(Style.as_inline_code Printtyp.type_expr) ty
7087
7076
7088
7077
let report_error ~loc env err =
7089
-
Printtyp.wrap_printing_env_error env
7078
+
Printtyp.wrap_printing_env ~error:true env
7090
7079
(fun () -> report_error ~loc env err)
7091
7080
7092
7081
let () =
+24
-24
typing/typedecl.ml
+24
-24
typing/typedecl.ml
···
1906
1906
1907
1907
(**** Error report ****)
1908
1908
1909
-
open Format
1909
+
open Format_doc
1910
1910
module Style = Misc.Style
1911
1911
1912
1912
let explain_unbound_gen ppf tv tl typ kwd pr =
···
1978
1978
List.iter Printtyp.add_type_to_preparation [ty1; ty2]
1979
1979
) path
1980
1980
1981
+
module Fmt = Format_doc
1982
+
1981
1983
let pp ppf reaching_path =
1982
1984
let pp_step ppf = function
1983
1985
| Expands_to (ty, body) ->
1984
-
Format.fprintf ppf "%a = %a"
1986
+
Fmt.fprintf ppf "%a = %a"
1985
1987
(Style.as_inline_code Printtyp.prepared_type_expr) ty
1986
1988
(Style.as_inline_code Printtyp.prepared_type_expr) body
1987
1989
| Contains (outer, inner) ->
1988
-
Format.fprintf ppf "%a contains %a"
1990
+
Fmt.fprintf ppf "%a contains %a"
1989
1991
(Style.as_inline_code Printtyp.prepared_type_expr) outer
1990
1992
(Style.as_inline_code Printtyp.prepared_type_expr) inner
1991
1993
in
1992
-
let comma ppf () = Format.fprintf ppf ",@ " in
1993
-
Format.(pp_print_list ~pp_sep:comma pp_step) ppf reaching_path
1994
+
Fmt.(pp_print_list ~pp_sep:comma) pp_step ppf reaching_path
1994
1995
1995
1996
let pp_colon ppf path =
1996
-
Format.fprintf ppf ":@;<1 2>@[<v>%a@]"
1997
-
pp path
1997
+
Fmt.fprintf ppf ":@;<1 2>@[<v>%a@]" pp path
1998
1998
end
1999
1999
2000
+
let quoted_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty
2000
2001
let report_error ppf = function
2001
2002
| Repeated_parameter ->
2002
2003
fprintf ppf "A type parameter occurs several times"
···
2036
2037
"the original" "this" "definition" env)
2037
2038
err
2038
2039
| Constraint_failed (env, err) ->
2040
+
let msg = Format_doc.Core.msg in
2039
2041
fprintf ppf "@[<v>Constraints are not satisfied in this type.@ ";
2040
2042
Printtyp.report_unification_error ppf env err
2041
-
(fun ppf -> fprintf ppf "Type")
2042
-
(fun ppf -> fprintf ppf "should be an instance of");
2043
+
(msg "Type")
2044
+
(msg "should be an instance of");
2043
2045
fprintf ppf "@]"
2044
2046
| Non_regular { definition; used_as; defined_as; reaching_path } ->
2045
2047
let reaching_path = Reaching_path.simplify reaching_path in
2046
-
let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in
2047
2048
Printtyp.prepare_for_printing [used_as; defined_as];
2048
2049
Reaching_path.add_to_preparation reaching_path;
2049
2050
fprintf ppf
···
2053
2054
All uses need to match the definition for the recursive type \
2054
2055
to be regular.@]"
2055
2056
Style.inline_code (Path.name definition)
2056
-
pp_type (Printtyp.tree_of_typexp Type defined_as)
2057
-
pp_type (Printtyp.tree_of_typexp Type used_as)
2057
+
quoted_type (Printtyp.tree_of_typexp Type defined_as)
2058
+
quoted_type (Printtyp.tree_of_typexp Type used_as)
2058
2059
(fun pp ->
2059
2060
let is_expansion = function Expands_to _ -> true | _ -> false in
2060
2061
if List.exists is_expansion reaching_path then
···
2062
2063
Reaching_path.pp_colon reaching_path
2063
2064
else fprintf pp ".@ ")
2064
2065
| Inconsistent_constraint (env, err) ->
2066
+
let msg = Format_doc.Core.msg in
2065
2067
fprintf ppf "@[<v>The type constraints are not consistent.@ ";
2066
2068
Printtyp.report_unification_error ppf env err
2067
-
(fun ppf -> fprintf ppf "Type")
2068
-
(fun ppf -> fprintf ppf "is not compatible with type");
2069
+
(msg "Type")
2070
+
(msg "is not compatible with type");
2069
2071
fprintf ppf "@]"
2070
2072
| Type_clash (env, err) ->
2073
+
let msg = Format_doc.Core.msg in
2071
2074
Printtyp.report_unification_error ppf env err
2072
-
(function ppf ->
2073
-
fprintf ppf "This type constructor expands to type")
2074
-
(function ppf ->
2075
-
fprintf ppf "but is used here with type")
2075
+
(msg "This type constructor expands to type")
2076
+
(msg "but is used here with type")
2076
2077
| Null_arity_external ->
2077
2078
fprintf ppf "External identifiers must be functions"
2078
2079
| Missing_native_external ->
···
2121
2122
"the type" "this extension" "definition" env)
2122
2123
err
2123
2124
| Rebind_wrong_type (lid, env, err) ->
2125
+
let msg = Format_doc.doc_printf in
2124
2126
Printtyp.report_unification_error ppf env err
2125
-
(function ppf ->
2126
-
fprintf ppf "The constructor %a@ has type"
2127
+
(msg "The constructor %a@ has type"
2127
2128
(Style.as_inline_code Printtyp.longident) lid)
2128
-
(function ppf ->
2129
-
fprintf ppf "but was expected to be of type")
2129
+
(msg "but was expected to be of type")
2130
2130
| Rebind_mismatch (lid, p, p') ->
2131
2131
fprintf ppf
2132
2132
"@[%s@ %a@ %s@ %a@ %s@ %s@ %a@]"
···
2256
2256
fprintf ppf "an unnamed existential variable"
2257
2257
| Some str ->
2258
2258
fprintf ppf "the existential variable %a"
2259
-
(Style.as_inline_code Pprintast.tyvar) str in
2259
+
(Style.as_inline_code Pprintast.Doc.tyvar) str in
2260
2260
fprintf ppf "@[This type cannot be unboxed because@ \
2261
2261
it might contain both float and non-float values,@ \
2262
2262
depending on the instantiation of %a.@ \
···
2271
2271
Style.inline_code "nonrec"
2272
2272
| Invalid_private_row_declaration ty ->
2273
2273
let pp_private ppf ty = fprintf ppf "private %a" Printtyp.type_expr ty in
2274
-
Format.fprintf ppf
2274
+
fprintf ppf
2275
2275
"@[<hv>This private row type declaration is invalid.@ \
2276
2276
The type expression on the right-hand side reduces to@;<1 2>%a@ \
2277
2277
which does not have a free row type variable.@]@,\
+1
-3
typing/typedecl.mli
+1
-3
typing/typedecl.mli
···
16
16
(* Typing of type definitions and primitive definitions *)
17
17
18
18
open Types
19
-
open Format
20
-
21
19
val transl_type_decl:
22
20
Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list ->
23
21
Typedtree.type_declaration list * Env.t * Shape.t list
···
111
109
112
110
exception Error of Location.t * error
113
111
114
-
val report_error: formatter -> error -> unit
112
+
val report_error: error Format_doc.printer
+28
-10
typing/typedtree.ml
+28
-10
typing/typedtree.ml
···
899
899
if they satisfy one of:
900
900
- Similar to an identifier: words separated by '.' or '#'.
901
901
- Do not contain spaces when printed.
902
-
*)
903
-
let rec exp_is_nominal exp =
904
-
match exp.exp_desc with
905
-
| _ when exp.exp_attributes <> [] -> false
906
-
| Texp_ident _ | Texp_instvar _ | Texp_constant _
907
-
| Texp_variant (_, None)
908
-
| Texp_construct (_, _, []) ->
909
-
true
910
-
| Texp_field (parent, _, _) | Texp_send (parent, _) -> exp_is_nominal parent
911
-
| _ -> false
902
+
*)
903
+
let nominal_exp_doc lid t =
904
+
let longident l = Format_doc.core lid l.Location.txt in
905
+
let rec nominal_exp_doc doc exp =
906
+
match exp.exp_desc with
907
+
| _ when exp.exp_attributes <> [] -> None
908
+
| Texp_ident (_,l,_) ->
909
+
Some (longident l doc)
910
+
| Texp_instvar (_,_,s) ->
911
+
Some (Format_doc.Core.string s.Location.txt doc)
912
+
| Texp_constant _ -> assert false
913
+
| Texp_variant (lbl, None) ->
914
+
Some (Format_doc.Core.printf "`%s" lbl doc)
915
+
| Texp_construct (l, _, []) -> Some (longident l doc)
916
+
| Texp_field (parent, lbl, _) ->
917
+
Option.map
918
+
(Format_doc.Core.printf ".%t" (longident lbl))
919
+
(nominal_exp_doc doc parent)
920
+
| Texp_send (parent, meth) ->
921
+
let name = match meth with
922
+
| Tmeth_name name -> name
923
+
| Tmeth_val id | Tmeth_ancestor (id,_) -> Ident.name id in
924
+
Option.map
925
+
(Format_doc.Core.printf "#%s" name)
926
+
(nominal_exp_doc doc parent)
927
+
| _ -> None
928
+
in
929
+
nominal_exp_doc Format_doc.empty t
+5
-3
typing/typedtree.mli
+5
-3
typing/typedtree.mli
···
920
920
val split_pattern:
921
921
computation general_pattern -> pattern option * pattern option
922
922
923
-
(** Whether an expression looks nice as the subject of a sentence in a error
924
-
message. *)
925
-
val exp_is_nominal : expression -> bool
923
+
(** Returns a format document if the expression reads nicely as the subject of a
924
+
sentence in a error message. *)
925
+
val nominal_exp_doc :
926
+
Longident.t Format_doc.printer -> expression
927
+
-> Format_doc.t option
+18
-19
typing/typemod.ml
+18
-19
typing/typemod.ml
···
19
19
open Asttypes
20
20
open Parsetree
21
21
open Types
22
-
open Format
22
+
open Format_doc
23
23
24
24
module Style = Misc.Style
25
25
···
2119
2119
in
2120
2120
Result.Error (Errortrace.Package_coercion msg)
2121
2121
| exception Includemod.Error e ->
2122
-
let msg = Includemod_errorprinter.err_msgs e in
2122
+
let msg = doc_printf "%a" Includemod_errorprinter.err_msgs e in
2123
2123
Result.Error (Errortrace.Package_inclusion msg)
2124
2124
2125
2125
let () = Ctype.package_subtype := package_subtype
···
2181
2181
| true , _ -> Includemod.Error.Empty_struct, mty
2182
2182
| false, Some p -> Includemod.Error.Named p, mty
2183
2183
| false, None -> Includemod.Error.Anonymous, mty
2184
+
2185
+
let not_principal msg = Warnings.Not_principal (Format_doc.Core.msg msg)
2184
2186
2185
2187
let rec type_module ?(alias=false) sttn funct_body anchor env smod =
2186
2188
Builtin_attributes.warning_scope smod.pmod_attributes
···
2308
2310
not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
2309
2311
then
2310
2312
Location.prerr_warning smod.pmod_loc
2311
-
(Warnings.Not_principal "this module unpacking");
2313
+
(not_principal "this module unpacking");
2312
2314
modtype_of_package env smod.pmod_loc p fl
2313
2315
| Tvar _ ->
2314
2316
raise (Typecore.Error
···
3097
3099
Typecore.force_delayed_checks ();
3098
3100
let shape = Shape_reduce.local_reduce Env.empty shape in
3099
3101
Printtyp.wrap_printing_env ~error:false initial_env
3100
-
(fun () -> fprintf std_formatter "%a@."
3102
+
Format.(fun () -> fprintf std_formatter "%a@."
3101
3103
(Printtyp.printed_signature @@ Unit_info.source_file target)
3102
3104
simple_sg
3103
3105
);
···
3291
3293
"@[This module is not a functor; it has type@ %a@]"
3292
3294
(Style.as_inline_code modtype) mty
3293
3295
| Not_included errs ->
3294
-
let main = Includemod_errorprinter.err_msgs errs in
3295
-
let footnote = Printtyp.Conflicts.err_msg in
3296
-
Location.errorf ~loc ~footnote "@[<v>Signature mismatch:@ %t@]" main
3296
+
Location.errorf ~loc ~footnote:Printtyp.Conflicts.err_msg
3297
+
"@[<v>Signature mismatch:@ %a@]"
3298
+
Includemod_errorprinter.err_msgs errs
3297
3299
| Cannot_eliminate_dependency mty ->
3298
3300
Location.errorf ~loc
3299
3301
"@[This functor has type@ %a@ \
···
3312
3314
Style.inline_code "with"
3313
3315
(Style.as_inline_code longident) lid
3314
3316
| With_mismatch(lid, explanation) ->
3315
-
let main = Includemod_errorprinter.err_msgs explanation in
3316
-
let footnote = Printtyp.Conflicts.err_msg in
3317
-
Location.errorf ~loc ~footnote
3317
+
Location.errorf ~loc ~footnote:Printtyp.Conflicts.err_msg
3318
3318
"@[<v>\
3319
3319
@[In this %a constraint, the new definition of %a@ \
3320
3320
does not match its original definition@ \
3321
3321
in the constrained signature:@]@ \
3322
-
%t@]"
3322
+
%a@]"
3323
3323
Style.inline_code "with"
3324
-
(Style.as_inline_code longident) lid main
3324
+
(Style.as_inline_code longident) lid
3325
+
Includemod_errorprinter.err_msgs explanation
3325
3326
| With_makes_applicative_functor_ill_typed(lid, path, explanation) ->
3326
-
let main = Includemod_errorprinter.err_msgs explanation in
3327
-
let footnote = Printtyp.Conflicts.err_msg in
3328
-
Location.errorf ~loc ~footnote
3327
+
Location.errorf ~loc ~footnote:Printtyp.Conflicts.err_msg
3329
3328
"@[<v>\
3330
3329
@[This %a constraint on %a makes the applicative functor @ \
3331
3330
type %a ill-typed in the constrained signature:@]@ \
3332
-
%t@]"
3331
+
%a@]"
3333
3332
Style.inline_code "with"
3334
3333
(Style.as_inline_code longident) lid
3335
3334
Style.inline_code (Path.name path)
3336
-
main
3335
+
Includemod_errorprinter.err_msgs explanation
3337
3336
| With_changes_module_alias(lid, id, path) ->
3338
3337
Location.errorf ~loc
3339
3338
"@[<v>\
···
3353
3352
[ 12; 7; 3 ]
3354
3353
in
3355
3354
let pp_constraint ppf () =
3356
-
Format.fprintf ppf "%s := %a"
3355
+
fprintf ppf "%s := %a"
3357
3356
(Path.name p) Printtyp.modtype mty
3358
3357
in
3359
3358
Location.errorf ~loc
···
3508
3507
Misc.print_see_manual manual_ref
3509
3508
3510
3509
let report_error env ~loc err =
3511
-
Printtyp.wrap_printing_env_error env
3510
+
Printtyp.wrap_printing_env ~error:true env
3512
3511
(fun () -> report_error env ~loc err)
3513
3512
3514
3513
let () =
+11
-14
typing/typetexp.ml
+11
-14
typing/typetexp.ml
···
857
857
858
858
(* Error report *)
859
859
860
-
open Format
860
+
open Format_doc
861
861
open Printtyp
862
862
module Style = Misc.Style
863
-
let pp_tag ppf t = Format.fprintf ppf "`%s" t
864
-
863
+
let pp_tag ppf t = fprintf ppf "`%s" t
864
+
let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty
865
865
866
866
let report_error env ppf = function
867
867
| Unbound_type_variable (name, in_scope_names) ->
···
881
881
(Style.as_inline_code longident) lid expected provided
882
882
| Bound_type_variable name ->
883
883
fprintf ppf "Already bound type parameter %a"
884
-
(Style.as_inline_code Pprintast.tyvar) name
884
+
(Style.as_inline_code Pprintast.Doc.tyvar) name
885
885
| Recursive_type ->
886
886
fprintf ppf "This type is recursive"
887
887
| Type_mismatch trace ->
888
+
let msg = Format_doc.Core.msg in
888
889
Printtyp.report_unification_error ppf Env.empty trace
889
-
(function ppf ->
890
-
fprintf ppf "This type")
891
-
(function ppf ->
892
-
fprintf ppf "should be an instance of type")
890
+
(msg "This type")
891
+
(msg "should be an instance of type")
893
892
| Alias_type_mismatch trace ->
893
+
let msg = Format_doc.Core.msg in
894
894
Printtyp.report_unification_error ppf Env.empty trace
895
-
(function ppf ->
896
-
fprintf ppf "This alias is bound to type")
897
-
(function ppf ->
898
-
fprintf ppf "but is used as an instance of type")
895
+
(msg "This alias is bound to type")
896
+
(msg "but is used as an instance of type")
899
897
| Present_has_conjunction l ->
900
898
fprintf ppf "The present constructor %a has a conjunctive type"
901
899
Style.inline_code l
···
912
910
Style.inline_code ">"
913
911
(Style.as_inline_code pp_tag) l
914
912
| Constructor_mismatch (ty, ty') ->
915
-
let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in
916
913
wrap_printing_env ~error:true env (fun () ->
917
914
Printtyp.prepare_for_printing [ty; ty'];
918
915
fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
···
942
939
| Cannot_quantify (name, v) ->
943
940
fprintf ppf
944
941
"@[<hov>The universal type variable %a cannot be generalized:@ "
945
-
(Style.as_inline_code Pprintast.tyvar) name;
942
+
(Style.as_inline_code Pprintast.Doc.tyvar) name;
946
943
if Btype.is_Tvar v then
947
944
fprintf ppf "it escapes its scope"
948
945
else if Btype.is_Tunivar v then
+1
-1
typing/typetexp.mli
+1
-1
typing/typetexp.mli
···
95
95
96
96
exception Error of Location.t * Env.t * error
97
97
98
-
val report_error: Env.t -> Format.formatter -> error -> unit
98
+
val report_error: Env.t -> error Format_doc.printer
99
99
100
100
(* Support for first-class modules. *)
101
101
val transl_modtype_longident: (* from Typemod *)
+4
-3
utils/diffing.ml
+4
-3
utils/diffing.ml
···
42
42
| Modification -> Misc.Style.[ FG Magenta; Bold]
43
43
44
44
let prefix ppf (pos, p) =
45
+
let open Format_doc in
45
46
let sty = style p in
46
-
Format.pp_open_stag ppf (Misc.Style.Style sty);
47
-
Format.fprintf ppf "%i. " pos;
48
-
Format.pp_close_stag ppf ()
47
+
pp_open_stag ppf (Misc.Style.Style sty);
48
+
fprintf ppf "%i. " pos;
49
+
pp_close_stag ppf ()
49
50
50
51
51
52
let (let*) = Option.bind
+1
-1
utils/diffing.mli
+1
-1
utils/diffing.mli
+3
-3
utils/diffing_with_keys.ml
+3
-3
utils/diffing_with_keys.ml
···
37
37
in
38
38
let style k ppf inner =
39
39
let sty = Diffing.style k in
40
-
Format.pp_open_stag ppf (Misc.Style.Style sty);
41
-
Format.kfprintf (fun ppf -> Format.pp_close_stag ppf () ) ppf inner
40
+
Format_doc.pp_open_stag ppf (Misc.Style.Style sty);
41
+
Format_doc.kfprintf (fun ppf -> Format_doc.pp_close_stag ppf () ) ppf inner
42
42
in
43
43
match x with
44
44
| Change (Name {pos; _ } | Type {pos; _})
···
53
53
54
54
(** To detect [move] and [swaps], we are using the fact that
55
55
there are 2-cycles in the graph of name renaming.
56
-
- [Change (x,y,_) is then an edge from
56
+
- [Change (x,y,_)] is then an edge from
57
57
[key_left x] to [key_right y].
58
58
- [Insert x] is an edge between the special node epsilon and
59
59
[key_left x]
+1
-1
utils/diffing_with_keys.mli
+1
-1
utils/diffing_with_keys.mli
+1
-1
utils/linkdeps.ml
+1
-1
utils/linkdeps.ml
+2
-4
utils/linkdeps.mli
+2
-4
utils/linkdeps.mli
···
57
57
- Some implementation appear
58
58
before their dependencies *)
59
59
60
-
open Format
61
60
62
-
val report_error
63
-
: print_filename:(formatter -> string -> unit)
64
-
-> formatter -> error -> unit
61
+
val report_error :
62
+
print_filename:string Format_doc.printer -> error Format_doc.printer
+14
-33
utils/misc.ml
+14
-33
utils/misc.ml
···
651
651
652
652
653
653
let as_inline_code printer ppf x =
654
-
Format.pp_open_stag ppf (Format.String_tag "inline_code");
654
+
let open Format_doc in
655
+
pp_open_stag ppf (Format.String_tag "inline_code");
655
656
printer ppf x;
656
-
Format.pp_close_stag ppf ()
657
+
pp_close_stag ppf ()
657
658
658
-
let inline_code ppf s = as_inline_code Format.pp_print_string ppf s
659
+
let inline_code ppf s = as_inline_code Format_doc.pp_print_string ppf s
659
660
660
661
(* either prints the tag of [s] or delegates to [or_else] *)
661
662
let mark_open_tag ~or_else s =
···
769
770
let env = List.sort_uniq (fun s1 s2 -> String.compare s2 s1) env in
770
771
fst (List.fold_left (compare name) ([], max_int) env)
771
772
773
+
772
774
let did_you_mean ppf get_choices =
775
+
let open Format_doc in
773
776
(* flush now to get the error report early, in the (unheard of) case
774
777
where the search in the get_choices function would take a bit of
775
778
time; in the worst case, the user has seen the error, she can
776
779
interrupt the process before the spell-checking terminates. *)
777
-
Format.fprintf ppf "@?";
780
+
fprintf ppf "@?";
778
781
match get_choices () with
779
782
| [] -> ()
780
783
| choices ->
781
784
let rest, last = split_last choices in
782
-
let comma ppf () = Format.fprintf ppf ", " in
783
-
Format.fprintf ppf "@\n@{<hint>Hint@}: Did you mean %a%s%a?@?"
784
-
(Format.pp_print_list ~pp_sep:comma Style.inline_code) rest
785
+
fprintf ppf "@\n@[@{<hint>Hint@}: Did you mean %a%s%a?@]"
786
+
(pp_print_list ~pp_sep:comma Style.inline_code) rest
785
787
(if rest = [] then "" else " or ")
786
788
Style.inline_code last
787
789
···
832
834
let stop = loop 0 0 in
833
835
Bytes.sub_string dst 0 stop
834
836
835
-
let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) =
836
-
let left_column_size =
837
-
List.fold_left (fun acc (s, _) -> Int.max acc (String.length s)) 0 lines in
838
-
let lines_nb = List.length lines in
839
-
let ellipsed_first, ellipsed_last =
840
-
match max_lines with
841
-
| Some max_lines when lines_nb > max_lines ->
842
-
let printed_lines = max_lines - 1 in (* the ellipsis uses one line *)
843
-
let lines_before = printed_lines / 2 + printed_lines mod 2 in
844
-
let lines_after = printed_lines / 2 in
845
-
(lines_before, lines_nb - lines_after - 1)
846
-
| _ -> (-1, -1)
847
-
in
848
-
Format.fprintf ppf "@[<v>";
849
-
List.iteri (fun k (line_l, line_r) ->
850
-
if k = ellipsed_first then Format.fprintf ppf "...@,";
851
-
if ellipsed_first <= k && k <= ellipsed_last then ()
852
-
else Format.fprintf ppf "%*s %s %s@," left_column_size line_l sep line_r
853
-
) lines;
854
-
Format.fprintf ppf "@]"
855
-
856
837
(* showing configuration and configuration variables *)
857
838
let show_config_and_exit () =
858
839
Config.print_config stdout;
···
909
890
[]
910
891
end
911
892
912
-
let print_if ppf flag printer arg =
913
-
if !flag then Format.fprintf ppf "%a@." printer arg;
914
-
arg
915
-
916
893
let print_see_manual ppf manual_section =
917
-
let open Format in
894
+
let open Format_doc in
918
895
fprintf ppf "(see manual section %a)"
919
896
(pp_print_list ~pp_sep:(fun f () -> pp_print_char f '.') pp_print_int)
920
897
manual_section
898
+
899
+
let print_if ppf flag printer arg =
900
+
if !flag then Format.fprintf ppf "%a@." printer arg;
901
+
arg
921
902
922
903
923
904
type filepath = string
+5
-30
utils/misc.mli
+5
-30
utils/misc.mli
···
445
445
list of suggestions taken from [env], that are close enough to
446
446
[name] that it may be a typo for one of them. *)
447
447
448
-
val did_you_mean : Format.formatter -> (unit -> string list) -> unit
448
+
val did_you_mean :
449
+
Format_doc.formatter -> (unit -> string list) -> unit
449
450
(** [did_you_mean ppf get_choices] hints that the user may have meant
450
451
one of the option returned by calling [get_choices]. It does nothing
451
452
if the returned list is empty.
···
505
506
inline_code: tag_style;
506
507
}
507
508
508
-
val as_inline_code: (Format.formatter -> 'a -> unit as 'printer) -> 'printer
509
-
val inline_code: Format.formatter -> string -> unit
509
+
val as_inline_code: 'a Format_doc.printer -> 'a Format_doc.printer
510
+
val inline_code: string Format_doc.printer
510
511
511
512
val default_styles: styles
512
513
val get_styles: unit -> styles
···
536
537
Format.formatter -> bool ref -> (Format.formatter -> 'a -> unit) -> 'a -> 'a
537
538
(** [print_if ppf flag fmt x] prints [x] with [fmt] on [ppf] if [b] is true. *)
538
539
539
-
val pp_two_columns :
540
-
?sep:string -> ?max_lines:int ->
541
-
Format.formatter -> (string * string) list -> unit
542
-
(** [pp_two_columns ?sep ?max_lines ppf l] prints the lines in [l] as two
543
-
columns separated by [sep] ("|" by default). [max_lines] can be used to
544
-
indicate a maximum number of lines to print -- an ellipsis gets inserted at
545
-
the middle if the input has too many lines.
546
-
547
-
Example:
548
-
549
-
{v pp_two_columns ~max_lines:3 Format.std_formatter [
550
-
"abc", "hello";
551
-
"def", "zzz";
552
-
"a" , "bllbl";
553
-
"bb" , "dddddd";
554
-
] v}
555
-
556
-
prints
557
-
558
-
{v
559
-
abc | hello
560
-
...
561
-
bb | dddddd
562
-
v}
563
-
*)
564
-
565
-
val print_see_manual : Format.formatter -> int list -> unit
540
+
val print_see_manual : int list Format_doc.printer
566
541
(** See manual section *)
567
542
568
543
(** {1 Displaying configuration variables} *)
+6
-4
utils/warnings.ml
+6
-4
utils/warnings.ml
···
52
52
| Implicit_public_methods of string list (* 15 *)
53
53
| Unerasable_optional_argument (* 16 *)
54
54
| Undeclared_virtual_method of string (* 17 *)
55
-
| Not_principal of string (* 18 *)
55
+
| Not_principal of Format_doc.t (* 18 *)
56
56
| Non_principal_labels of string (* 19 *)
57
57
| Ignored_extra_argument (* 20 *)
58
58
| Nonreturning_statement (* 21 *)
···
926
926
^ String.concat " " l ^ "."
927
927
| Unerasable_optional_argument -> "this optional argument cannot be erased."
928
928
| Undeclared_virtual_method m -> "the virtual method "^m^" is not declared."
929
-
| Not_principal s -> s^" is not principal."
929
+
| Not_principal msg ->
930
+
Format_doc.asprintf "%a is not principal."
931
+
Format_doc.pp_doc msg
930
932
| Non_principal_labels s -> s^" without principality."
931
933
| Ignored_extra_argument -> "this argument will not be used by the function."
932
934
| Nonreturning_statement ->
···
1040
1042
"Code should not depend on the actual values of\n\
1041
1043
this constructor's arguments. They are only for information\n\
1042
1044
and may change in future versions. %a"
1043
-
Misc.print_see_manual ref_manual
1045
+
(Format_doc.compat Misc.print_see_manual) ref_manual
1044
1046
| Unreachable_case ->
1045
1047
"this match case is unreachable.\n\
1046
1048
Consider replacing it with a refutation case '<pat> -> .'"
···
1071
1073
%s.\n\
1072
1074
Only the first match will be used to evaluate the guard expression.\n\
1073
1075
%a"
1074
-
vars_explanation Misc.print_see_manual ref_manual
1076
+
vars_explanation (Format_doc.compat Misc.print_see_manual) ref_manual
1075
1077
| No_cmx_file name ->
1076
1078
Printf.sprintf
1077
1079
"no cmx file was found in path for module %s, \
+1
-1
utils/warnings.mli
+1
-1
utils/warnings.mli
···
57
57
| Implicit_public_methods of string list (* 15 *)
58
58
| Unerasable_optional_argument (* 16 *)
59
59
| Undeclared_virtual_method of string (* 17 *)
60
-
| Not_principal of string (* 18 *)
60
+
| Not_principal of Format_doc.t (* 18 *)
61
61
| Non_principal_labels of string (* 19 *)
62
62
| Ignored_extra_argument (* 20 *)
63
63
| Nonreturning_statement (* 21 *)